Dữ liệu có sẵn theo cột dọc Xin giúp tạo bảng theo hàng ngang

[tle2003]

Xin các anh chị em gíup giùm.
Dữ liệu có sẵn, mình tạo thành bảng để tiện xử dụng.
Cám ơn

 

[SA_DQ]

Bạn cho chạy cặp macro cha con cù lần này:

Sub ChuyenBangSangNgang()
Dim Dat As Date, J As Long, Hg As Integer, Rws As Long
Dim Rng As Range, sRng As Range
Dim MyAdd As String

Dat = #2/1/2021#:                      Rws = [C65500].End(xlUp).Row
Set Rng = Range([C1], Cells(Rws, "C"))
[H2].CurrentRegion.Offset(1).Resize(Rws).Clear
Rng.NumberFormat = "MM/DD/yyyy"
For J = 0 To 30
    Set sRng = Rng.Find(Format(Dat + J, "MM/DD/yyyy"), , xlValues, xlWhole)
    If Not sRng Is Nothing Then
        MyAdd = sRng.Address
        Do
            Hg = [H65500].End(xlUp).Offset(1).Row
            sRng.Resize(, 2).Copy Destination:=Cells(Hg, "H")
            CopyGPE sRng.Offset(1).Resize(5), Cells(Hg, "J")
            Set sRng = Rng.FindNext(sRng)
        Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
    Else
    End If
Next J
End Sub

Sub CopyGPE(Rg0 As Range, Rg1 As Range)
    Rg0.Select:             Selection.Copy
    Rg1.Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End Sub

Chúc mọi người vui nhân dịp Tết đến, xuân về!

 

[ptm0412]

Bạn cho chạy cặp macro cha con cù lần này

Code này đỡ cù lần hơn 1 tẹo

Sub VerToHor()
Dim NextRw As Long, RngSequence As Range, LastDataRw As Long
LastDataRw = Cells(10000, 4).End(xlUp).Row
Range("H3:N1000").ClearContents
Set RngSequence = Cells(2, 4)
Do
    Set RngSequence = RngSequence.End(xlDown)
    If RngSequence.Row > LastDataRw Then Exit Do
    NextRw = Cells(1000, 8).End(xlUp).Row + 1
    Cells(NextRw, 8).Resize(1, 2).Value = RngSequence.Offset(0, -1).Resize(1, 2).Value
    Cells(NextRw, 10).Resize(1, 5).Value = Application.Transpose(RngSequence.Offset(1, -1).Resize(5, 1))
   
Loop
End Sub

 

[tle2003]

Bạn cho chạy cặp macro cha con cù lần này:

Sub ChuyenBangSangNgang()
Dim Dat As Date, J As Long, Hg As Integer, Rws As Long
Dim Rng As Range, sRng As Range
Dim MyAdd As String

Dat = #2/1/2021#:                      Rws = [C65500].End(xlUp).Row
Set Rng = Range([C1], Cells(Rws, "C"))
[H2].CurrentRegion.Offset(1).Resize(Rws).Clear
Rng.NumberFormat = "MM/DD/yyyy"
For J = 0 To 30
    Set sRng = Rng.Find(Format(Dat + J, "MM/DD/yyyy"), , xlValues, xlWhole)
    If Not sRng Is Nothing Then
        MyAdd = sRng.Address
        Do
            Hg = [H65500].End(xlUp).Offset(1).Row
            sRng.Resize(, 2).Copy Destination:=Cells(Hg, "H")
            CopyGPE sRng.Offset(1).Resize(5), Cells(Hg, "J")
            Set sRng = Rng.FindNext(sRng)
        Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
    Else
    End If
Next J
End Sub

Sub CopyGPE(Rg0 As Range, Rg1 As Range)
    Rg0.Select:             Selection.Copy
    Rg1.Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End Sub

Chúc mọi người vui nhân dịp Tết đến, xuân về!

Cám ơn bác nhiều

Bài đã được tự động gộp: 11/2/21

Code này đỡ cù lần hơn 1 tẹo

Sub VerToHor()
Dim NextRw As Long, RngSequence As Range, LastDataRw As Long
LastDataRw = Cells(10000, 4).End(xlUp).Row
Range("H3:N1000").ClearContents
Set RngSequence = Cells(2, 4)
Do
    Set RngSequence = RngSequence.End(xlDown)
    If RngSequence.Row > LastDataRw Then Exit Do
    NextRw = Cells(1000, 8).End(xlUp).Row + 1
    Cells(NextRw, 8).Resize(1, 2).Value = RngSequence.Offset(0, -1).Resize(1, 2).Value
    Cells(NextRw, 10).Resize(1, 5).Value = Application.Transpose(RngSequence.Offset(1, -1).Resize(5, 1))
  
Loop
End Sub

Cám ơn bác nhiều