Chuyển bảng dữ liệu cột thành dòng bằng VBA

[Congky74]

Kính gửi: Các Anh chị trên diễn đàn.
Hiện tại em đang muốn chuyển sheet A thành sheet B: như file đính kèm.
. Mong các anh chị giúp em viết code để chuyển . (dữ liệu em chỉ làm ví dụ ). Cảm ơn các anh chị ạ!

 

[ptm0412]

Dùng Power query Unpivot

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    Unpivoted = Table.UnpivotOtherColumns(Source, {"Ngày", "Tuần", "Tháng", "mã hàng", "Tên Hàng", "Người phụ trách", "ĐVT"}, "Khối", "Sluong"),
    ChangedType = Table.TransformColumnTypes(Unpivoted,{{"Sluong", type number}, {"Ngày", type date}})
in
    ChangedType

 

[Congky74]

Dùng Power query Unpivot

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    Unpivoted = Table.UnpivotOtherColumns(Source, {"Ngày", "Tuần", "Tháng", "mã hàng", "Tên Hàng", "Người phụ trách", "ĐVT"}, "Khối", "Sluong"),
    ChangedType = Table.TransformColumnTypes(Unpivoted,{{"Sluong", type number}, {"Ngày", type date}})
in
    ChangedType

Dạ con cảm ơn thầy nhiều. Nhưng máy con dùng office 2010 với lại con chưa biết dùng Power query Unpivot được. mong thầy giúp con bằng file mềm ạ. con xin chân thành cảm ơn thầy và diễn đàn nhiều.!

 

[SA_DQ]

Bạn xài thử củ khoai mì này:

Sub ChuyenThanhBangDoc()
 Dim J As Long, W As Integer, Rws As Long, Col As Integer, Cot As Integer
 Dim Cls As Range
 
 Sheets("A").Select
 Set Cls = [B3].CurrentRegion
 Rws = Cls.Rows.Count:                  Col = Cls.Columns.Count
 ReDim Arr(1 To Col * Rws, 1 To 9):     Sheets("B").[A3].Resize(Col * Rws, 9).ClearContents
 For Each Cls In Range([A3], [A3].End(xlDown))
    For Cot = 8 To 16
        If Cells(Cls.Row, Cot).Value <> Space(0) Then
            W = W + 1
            For Col = 1 To 7
                Arr(W, Col) = Cells(Cls.Row, Col).Value
            Next Col
            Arr(W, 8) = Cells(2, Cot).Value
            Arr(W, 9) = Cells(Cls.Row, Cot).Value
        End If
    Next Cot
 Next Cls
 If W Then
    MsgBox W
    'Sheets("B").[A3].Resize(W, 9).Value = Arr()     '
 End If
End Sub

 

[Congky74]

Bạn xài thử củ khoai mì này:

Sub ChuyenThanhBangDoc()
 Dim J As Long, W As Integer, Rws As Long, Col As Integer, Cot As Integer
 Dim Cls As Range
 
 Sheets("A").Select
 Set Cls = [B3].CurrentRegion
 Rws = Cls.Rows.Count:                  Col = Cls.Columns.Count
 ReDim Arr(1 To Col * Rws, 1 To 9):     Sheets("B").[A3].Resize(Col * Rws, 9).ClearContents
 For Each Cls In Range([A3], [A3].End(xlDown))
    For Cot = 8 To 16
        If Cells(Cls.Row, Cot).Value <> Space(0) Then
            W = W + 1
            For Col = 1 To 7
                Arr(W, Col) = Cells(Cls.Row, Col).Value
            Next Col
            Arr(W, 8) = Cells(2, Cot).Value
            Arr(W, 9) = Cells(Cls.Row, Cot).Value
        End If
    Next Cot
 Next Cls
 If W Then
    MsgBox W
    'Sheets("B").[A3].Resize(W, 9).Value = Arr()     '
 End If
End Sub

Con cảm ơn bác đã viết code cho con. con áp dụng nó chạy được rồi bác ạ!

 

[Ba Tê]

Con cảm ơn bác đã viết code cho con. con áp dụng nó chạy được rồi bác ạ!

Bỏ dấu nháy đơn trước dòng lệnh này xem sao
'Sheets("B").[A3].Resize(W, 9).Value = Arr()

 

[Congky74]

Bỏ dấu nháy đơn trước dòng lệnh này xem sao
'Sheets("B").[A3].Resize(W, 9).Value = Arr()

Con cảm ơn thầy đã quan tâm đến con ạ. con làm như vậy nó chạy ngon lành rồi thầy ạ.

 

[befaint]

Con cảm ơn thầy đã quan tâm đến con ạ.

Hình như thầy mới quan tâm tới bài hỏi, chưa thấy chỗ nào 'quan tâm tới con'.

 

[Congky74]

Hình như thầy mới quan tâm tới bài hỏi, chưa thấy chỗ nào 'quan tâm tới con'.

Dạ. được như vậy là hạnh phúc rồi thầy ạ. con cảm ơn tất cả mọi người ạ!