Chuyển dữ liệu từ cột thành hàng vba

bigbabol89 · 14/4/21

Xin chào các anh chị,
Em muốn nhờ các anh chị giúp : chuyển dữ liệu từ cột thành hàng ( như file đính kèm ).
Mong các anh chị giúp đỡ ạ.
Em cám ơn ạ.

Nhattanktnn · 14/4/21

bigbabol89 đã viết:
Xin chào các anh chị,
Em muốn nhờ các anh chị giúp : chuyển dữ liệu từ cột thành hàng ( như file đính kèm ).
Mong các anh chị giúp đỡ ạ.
Em cám ơn ạ.
View attachment 257071

Bài này powerquery unpivot columns nhanh lắm

befaint · 14/4/21

Nhattanktnn đã viết:
Bài này powerquery unpivot columns nhanh lắm

Chưa chắc nhé.

bigbabol89 · 14/4/21

Nhattanktnn đã viết:
Bài này powerquery unpivot columns nhanh lắm

Cái này em cũng không biết làm, mà do file em cũng chia sẻ cho nhiều người nên em nghĩ dùng vba sẽ hợp hơn ( vì mọi người cũng giống em

)

Nhattanktnn · 14/4/21

befaint đã viết:
Chưa chắc nhé.

Em làm thử thấy cũng nhanh mà anh, mà không rõ ý "chưa chắc" của anh là gì

bigbabol89 đã viết:
Cái này em cũng không biết làm, mà do file em cũng chia sẻ cho nhiều người nên em nghĩ dùng vba sẽ hợp hơn ( vì mọi người cũng giống em )

Power query thì hơi phiền phức về phần office nữa. Không phải office nào cũng có

ptm0412 · 14/4/21

Nhattanktnn đã viết:
Em làm thử thấy cũng nhanh mà anh, mà không rõ ý "chưa chắc" của anh là gì

Thử power query với 100 ngàn dòng, unpivot 4 cột trở thành 400 ngàn dòng thì sẽ biết nhanh hay chậm nếu so với VBA sử dụng mảng. Ưu điểm của Power query là đơn giản, thao tác bằng tay đơn giản, ai cũng tự làm được. Nếu lưu kết quả ở Data Model thì file cũng nhẹ hơn, mà dùng được cho các báo cáo khác.

BuiQuangThuan · 14/4/21

bigbabol89 đã viết:
Xin chào các anh chị,
Em muốn nhờ các anh chị giúp : chuyển dữ liệu từ cột thành hàng ( như file đính kèm ).
Mong các anh chị giúp đỡ ạ.
Em cám ơn ạ.

Xin chạy thử code. Chỗ nào sai mọi người góp ý thêm

Mã:

Sub ABC()
Dim iR&, iC&, i&, sArr(), Res(), j&, K&
With Sheets("Sheet1")
    iR = .Range("A" & Rows.Count).End(3).Row - 1
    iC = .Cells(2, "XFD").End(1).Column
    sArr = .Range("A2").Resize(iR, iC).Value
End With
ReDim Res(1 To UBound(sArr, 1) * (iC - 1), 1 To 3)
    For j = 2 To UBound(sArr, 2)
        For i = 2 To UBound(sArr, 1)
            K = K + 1
            Res(K, 1) = sArr(i, 1)
            Res(K, 2) = sArr(1, j)
            Res(K, 3) = sArr(i, j)
        Next
    Next
With Sheets("Sheet2")
    .Range("A2").Resize(10000, 3).ClearContents
    If K Then .Range("A2").Resize(K, 3).Value = Res
End With
MsgBox "Da xong"
End Sub

bigbabol89 · 15/4/21

buiquangthuan đã viết:

Xin chạy thử code. Chỗ nào sai mọi người góp ý thêm

Mã:

Sub ABC()
Dim iR&, iC&, i&, sArr(), Res(), j&, K&
With Sheets("Sheet1")
    iR = .Range("A" & Rows.Count).End(3).Row - 1
    iC = .Cells(2, "XFD").End(1).Column
    sArr = .Range("A2").Resize(iR, iC).Value
End With
ReDim Res(1 To UBound(sArr, 1) * (iC - 1), 1 To 3)
    For j = 2 To UBound(sArr, 2)
        For i = 2 To UBound(sArr, 1)
            K = K + 1
            Res(K, 1) = sArr(i, 1)
            Res(K, 2) = sArr(1, j)
            Res(K, 3) = sArr(i, j)
        Next
    Next
With Sheets("Sheet2")
    .Range("A2").Resize(10000, 3).ClearContents
    If K Then .Range("A2").Resize(K, 3).Value = Res
End With
MsgBox "Da xong"
End Sub

Code chạy rất tốt anh ạ.
Em cám ơn anh rất nhiều.

cadafi · 15/4/21

Chào Bạn,
Bạn thử code này xem sao! Lưu ý sản phẩm có điều kiện nhé.

PHP:

Sub iTransposeData()
Application.CutCopyMode = False
'--------------------------------------------------------------------------------------------------------------------------------------------
For Each tbl In ActiveSheet.ListObjects
If tbl.Name = "tbl_Data" Then tbl.Unlist
Next
'--------------------------------------------------------------------------------------------------------------------------------------------
Dim MyTblRange As Range: Set MyTblRange = Application.InputBox("Select the source data-range to transpose:", "Data source", Type:=8)
ActiveSheet.ListObjects.Add(SourceType:=xlSrcRange, Source:=MyTblRange, xlListObjectHasHeaders:=xlYes).Name = "tbl_Data"
'--------------------------------------------------------------------------------------------------------------------------------------------
Dim iRngDestination As Range: Set iRngDestination = Application.InputBox("Select a range to place your data:", "Data unpivotcolumn", Type:=8)
'--------------------------------------------------------------------------------------------------------------------------------------------
For i = 1 To ActiveWorkbook.Queries.Count
    If ActiveWorkbook.Queries.Item(i).Name = "qry_Data" Then ActiveWorkbook.Queries.Item(i).Delete
Next i
'--------------------------------------------------------------------------------------------------------------------------------------------
ActiveWorkbook.Queries.Add Name:="qry_Data", Formula:= _
        "let" & Chr(13) & "" & Chr(10) & "    Source = Excel.CurrentWorkbook(){[Name=""tbl_Data""]}[Content]," & Chr(13) & "" & Chr(10) & "    #""Changed Type"" = Table.TransformColumnTypes(Source,{{""Date"", type datetime}, {""A"", Int64.Type}, {""B"", Int64.Type}, {""C"", Int64.Type}, {""D"", Int64.Type}})," & Chr(13) & "" & Chr(10) & "    #""Unpivoted Columns"" = Table.UnpivotOtherColumns(#""Changed Type"", {""Date""}, ""Attribute"", ""Value"")," & Chr(13) & "" & Chr(10) & "    #""" & _
        "Changed Type1"" = Table.TransformColumnTypes(#""Unpivoted Columns"",{{""Date"", type date}})," & Chr(13) & "" & Chr(10) & "    #""Sorted Rows"" = Table.Sort(#""Changed Type1"",{{""Attribute"", Order.Ascending}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    #""Sorted Rows"""
  
'--------------------------------------------------------------------------------------------------------------------------------------------
    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
        "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=""qry_Data"";Extended Properties=""""" _
        , Destination:=iRngDestination).QueryTable
        .CommandType = xlCmdSql
        .CommandText = Array("SELECT * FROM [qry_Data]")
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .ListObject.DisplayName = "tbl_Data_" & Format(Now(), "DDMMYY_hhmmss")
        .Refresh BackgroundQuery:=False
    End With
'--------------------------------------------------------------------------------------------------------------------------------------------
End Sub

thuyyeu99 · 15/4/21

Bạn dùng SQL cũng được

cadafi · 15/4/21

Bạn thử thêm 1 cách khác không dùng Power Query xem có nhanh hơn cách trên mình làm không nhé. Test thử 5,000 dòng.

PHP:

Sub iTransposeSQL()
Dim MyTbl As Range: Set MyTbl = Application.InputBox("Select the source data-range to transpose:", "Data source", Type:=8)
Dim iDestination As Range: Set iDestination = Application.InputBox("Select a range to place your data:", "Data unpivotcolumn", Type:=8)
Dim mTbl As String: mTbl = "[" & ActiveSheet.Name & "$" & Replace(MyTbl.Address, "$", "") & "]"
'-----------------------------------------------------------------------------------------------------------------------------------------
Dim mSQL As String
mSQL = "SELECT [DATE], 'A', A FROM " & mTbl & Chr(10) & "UNION ALL" & Chr(10)
mSQL = mSQL & "SELECT [DATE], 'B', B FROM " & mTbl & Chr(10) & "UNION ALL" & Chr(10)
mSQL = mSQL & "SELECT [DATE], 'C', C FROM " & mTbl & Chr(10) & "UNION ALL" & Chr(10)
mSQL = mSQL & "SELECT [DATE], 'D', D FROM " & mTbl
'-----------------------------------------------------------------------------------------------------------------------------------------
Application.CutCopyMode = False
'-----------------------------------------------------------------------------------------------------------------------------------------
With CreateObject("ADODB.Connection")
    .Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=""Excel 12.0;HDR=YES"";Data Source=" & ThisWorkbook.FullName
    iDestination.Offset(1, 0).CopyFromRecordset .Execute(mSQL)
End With
'-----------------------------------------------------------------------------------------------------------------------------------------
End Sub

HeSanbi · 16/4/21

bigbabol89

Bạn tham khảo code VBA dưới đây:

Bạn chỉ cần gõ vào Ô trả kết quả, Nếu Vùng A2 giá trị thêm hoặc bớt thì code tự động

=S_JoinV(A2:E100000)

PHP:

'                    _,
' ___   _   _  _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'
Option Explicit
#If VBA7 Then
  Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
  Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
  Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If
Private Type TypeArgs
  Action As Long
  Target As Range
  Caller As Range
  Formula As String
End Type

#If VBA7 And Win64 Then
  Private gTimerID As LongPtr
#Else
  Private gTimerID As Long
#End If
Private Args() As TypeArgs, WorkIndex As Integer

Function S_JoinV(ByVal Target As Range) As Variant

  On Error Resume Next
  Dim k&, r, F$
  Set r = Application.Caller
  F = r(1, 1).Formula
  k = UBound(Args)

  S_JoinV = Target(2, 1).Value

  ReDim Preserve Args(1 To k + 1)
  With Args(k + 1)
    Set .Target = Target
    .Formula = F
    Set .Caller = r
    .Action = 0
  End With
  If gTimerID = 0 Then
    gTimerID = SetTimer(0&, 0&, 1, AddressOf S_JoinV_callback)
  End If

End Function

Private Sub S_JoinV_callback()
  On Error Resume Next
  Call KillTimer(0&, gTimerID): gTimerID = 0
  S_JoinV_working
  On Error GoTo 0
End Sub

Private Sub S_JoinV_working()
  On Error Resume Next
  Dim UA%, s$
  UA = UBound(Args)
  If UA > 0 Then
    WorkIndex = WorkIndex + 1
    Dim a As TypeArgs, AP As Object
    a = Args(WorkIndex)
    Set AP = a.Caller.Parent.Parent.Parent
    If a.Action <> 0 Or a.Caller.Formula <> a.Formula Then
      GoTo N
    End If
    Args(WorkIndex).Action = 1
    '//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//
    Dim SU As Boolean, AC As Long
    SU = AP.ScreenUpdating
    AC = AP.Calculation
    If AC <> -4135 Then
      AP.Calculation = -4135
    End If
    If SU Then
      AP.ScreenUpdating = False
    End If
    Dim w, r, lr&, C%

    Set w = a.Target.Parent
    Set r = a.Target(2, 1)
    lr = r(a.Target.Rows.Count - 1, 1).End(3).Row - r.Row + 1
    a.Caller(2, 1).Resize(w.Rows.Count - a.Caller.Row, 3).ClearContents
    If lr > 0 And a.Target.Columns.Count > 1 Then
      For C = 1 To a.Target.Columns.Count - 1
        If C * lr + 1 > w.Rows.Count Then
          Exit For
        End If
        If C = 1 Then
          a.Caller((C - 1) * lr + 2, 1).Resize(lr - 1, 1).Value = r(2, 1).Resize(lr - 1, 1).Value
        Else
          a.Caller((C - 1) * lr + 1, 1).Resize(lr, 1).Value = r(1, 1).Resize(lr, 1).Value
        End If
        a.Caller((C - 1) * lr + 1, 2).Resize(lr, 1).Value = r(0, C + 1).Value
        a.Caller((C - 1) * lr + 1, 3).Resize(lr, 1).Value = r(1, C + 1).Resize(lr, 1).Value
      Next
    End If

    If SU And SU <> AP.ScreenUpdating Then
      AP.ScreenUpdating = SU
    End If
    If AP.Calculation <> AC And AC = -4105 Then
      AP.Calculation = AC
    End If

Ends:
    '//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//'//
    Set r = Nothing
    Set w = Nothing: Set AP = Nothing
N:
    If WorkIndex >= UA Then
      Erase Args: WorkIndex = 0
    Else
      gTimerID = SetTimer(0&, 0&, 1, AddressOf S_JoinV_callback)
    End If
  End If
On Error GoTo 0

End Sub

Chuyển dữ liệu từ cột thành hàng vba

bigbabol89

Thành viên thường trực

File đính kèm

Nhattanktnn

Thành viên gắn bó

befaint

|||||||||||||

bigbabol89

Thành viên thường trực

Nhattanktnn

Thành viên gắn bó

ptm0412

Bad Excel Member

BuiQuangThuan

❆❆❆❆❆❆❆❆❆❆❆❆

bigbabol89

Thành viên thường trực

cadafi

Hành động từ trái tim

File đính kèm

thuyyeu99

Trùm Nhiều Chuyện

cadafi

Hành động từ trái tim

File đính kèm

HeSanbi

Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨

bigbabol89

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Chuyển dữ liệu từ cột thành hàng vba

Thành viên thường trực

File đính kèm

Thành viên gắn bó

|||||||||||||

Thành viên thường trực

Thành viên gắn bó

Bad Excel Member

❆❆❆❆❆❆❆❆❆❆❆❆

Thành viên thường trực

Hành động từ trái tim

File đính kèm

Trùm Nhiều Chuyện

Hành động từ trái tim

File đính kèm

Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨

bigbabol89​

bigbabol89