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

[tranvanhung2009]

Chào các bạn.
Mình có 1 file cell cần xử lý số liệu từ dòng chuyển thành cột.
Mình cần 1 đoạn VBA để xử lý bảng dữ liệu này.
Nội dung cần chuyển mình đã trình bày trong file excell.
Rất mong được sự giúp đỡ của mọi người.
Cám ơn các bạn nhiều!

 

[HieuCD]

Chào các bạn.
Mình có 1 file cell cần xử lý số liệu từ dòng chuyển thành cột.
Mình cần 1 đoạn VBA để xử lý bảng dữ liệu này.
Nội dung cần chuyển mình đã trình bày trong file excell.
Rất mong được sự giúp đỡ của mọi người.
Cám ơn các bạn nhiều!

Sub LungTung()
  Dim sArr(), sArr2(), atO(), atO2(), atG(), atG2(), Res(), Res2()
  Dim eRow&, sRow&, eCol&, i&, j&, r&, c&, n&
  Dim aTDdong(), aTDcot(), iText$
  With Sheets("So lieu")
    iText = Left(.Range("C5").Value, 7) & "dòng "
  End With
  With Sheets("Du lieu")
    eRow = .Range("AC" & Rows.Count).End(xlUp).Row
    sArr = .Range("AT6:BK" & eRow).Value
    sArr2 = .Range("CY6:DP" & eRow).Value
    atO = .Range("AG6:AG" & eRow).Value
    atO2 = .Range("CG6:CG" & eRow).Value
    atG = .Range("AC6:AC" & eRow).Value
    atG2 = .Range("CV6:CV" & eRow).Value
  End With
  sRow = UBound(sArr)
  ReDim aTDdong(1 To sRow * 4, 1 To 1)
  ReDim Res(1 To sRow * 4, 1 To 3)
  ReDim aTDcot(1 To 1, 1 To sRow * 4)
  ReDim Res2(1 To 9, 1 To sRow * 4)
  r = -3: c = -3
  For i = 1 To sRow
    'Ket qua 1
    r = r + 4
    aTDdong(r, 1) = iText & i

    Res(r, 1) = sArr(i, 1) 'toa do O
    Res(r, 2) = sArr(i, 2)
    Res(r, 3) = atO(i, 1)

    Res(r + 1, 1) = sArr(i, 17) 'toa do G
    Res(r + 1, 2) = sArr(i, 18)
    Res(r + 1, 3) = atG(i, 1)

    Res(r + 2, 1) = sArr2(i, 1) 'toa do O'
    Res(r + 2, 2) = sArr2(i, 2)
    Res(r + 2, 3) = atO2(i, 1)

    Res(r + 3, 1) = sArr2(i, 17) 'toa do G'
    Res(r + 3, 2) = sArr2(i, 18)
    Res(r + 3, 3) = atG2(i, 1)
    'Ket qua 2
    c = c + 4
    aTDcot(1, c) = iText & i
    For n = 1 To 9
      Res2(n, c) = sArr(i, (n - 1) * 2 + 1)
      Res2(n, c + 1) = sArr(i, n * 2)
      Res2(n, c + 2) = sArr2(i, (n - 1) * 2 + 1)
      Res2(n, c + 3) = sArr2(i, n * 2)
    Next n
  Next i
 
  With Sheets("So lieu")
    'Ket qua 1
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 10 Then .Range("A11:E" & eRow).Clear
    eRow = UBound(Res) + 6
    If eRow > 10 Then
      .Range("A7:B10").Copy .Range("A11:E" & eRow)
    End If
    .Range("A7:A" & eRow) = aTDdong
    .Range("C7:E" & eRow) = Res
    .Range("C7:E" & eRow).Borders.LineStyle = 1
    'Ket qua 2
    eCol = .Cells(6, 10000).End(xlToLeft).Column
    If eCol > 10 Then .Range("K5", .Cells(15, eCol)).Clear
    eCol = UBound(Res2, 2) + 6
    If eCol > 10 Then
      .Range("G5:J6").Copy .Range("K5", .Cells(6, eCol))
    End If
    .Range("G5", .Cells(5, eCol)) = aTDcot
    .Range("G7", .Cells(15, eCol)) = Res2
    .Range("G5", .Cells(15, eCol)).Borders.LineStyle = 1
  End With
End Sub

Hơi rối

 

[BuiQuangThuan]

Sub LungTung()
  Dim sArr(), sArr2(), atO(), atO2(), atG(), atG2(), Res(), Res2()
  Dim eRow&, sRow&, eCol&, i&, j&, r&, c&, n&
  Dim aTDdong(), aTDcot(), iText$

Hơi rối

sao giờ tự nhiên thấy thầy dim kiểu này nhìn lạ lạ

 

[HieuCD]

sao giờ tự nhiên thấy thầy dim kiểu này nhìn lạ lạ

Để lệnh Dim ngắn hơn

 

[tranvanhung2009]

Sub LungTung()
  Dim sArr(), sArr2(), atO(), atO2(), atG(), atG2(), Res(), Res2()
  Dim eRow&, sRow&, eCol&, i&, j&, r&, c&, n&
  Dim aTDdong(), aTDcot(), iText$
  With Sheets("So lieu")
    iText = Left(.Range("C5").Value, 7) & "dòng "
  End With
  With Sheets("Du lieu")
    eRow = .Range("AC" & Rows.Count).End(xlUp).Row
    sArr = .Range("AT6:BK" & eRow).Value
    sArr2 = .Range("CY6:DP" & eRow).Value
    atO = .Range("AG6:AG" & eRow).Value
    atO2 = .Range("CG6:CG" & eRow).Value
    atG = .Range("AC6:AC" & eRow).Value
    atG2 = .Range("CV6:CV" & eRow).Value
  End With
  sRow = UBound(sArr)
  ReDim aTDdong(1 To sRow * 4, 1 To 1)
  ReDim Res(1 To sRow * 4, 1 To 3)
  ReDim aTDcot(1 To 1, 1 To sRow * 4)
  ReDim Res2(1 To 9, 1 To sRow * 4)
  r = -3: c = -3
  For i = 1 To sRow
    'Ket qua 1
    r = r + 4
    aTDdong(r, 1) = iText & i

    Res(r, 1) = sArr(i, 1) 'toa do O
    Res(r, 2) = sArr(i, 2)
    Res(r, 3) = atO(i, 1)

    Res(r + 1, 1) = sArr(i, 17) 'toa do G
    Res(r + 1, 2) = sArr(i, 18)
    Res(r + 1, 3) = atG(i, 1)

    Res(r + 2, 1) = sArr2(i, 1) 'toa do O'
    Res(r + 2, 2) = sArr2(i, 2)
    Res(r + 2, 3) = atO2(i, 1)

    Res(r + 3, 1) = sArr2(i, 17) 'toa do G'
    Res(r + 3, 2) = sArr2(i, 18)
    Res(r + 3, 3) = atG2(i, 1)
    'Ket qua 2
    c = c + 4
    aTDcot(1, c) = iText & i
    For n = 1 To 9
      Res2(n, c) = sArr(i, (n - 1) * 2 + 1)
      Res2(n, c + 1) = sArr(i, n * 2)
      Res2(n, c + 2) = sArr2(i, (n - 1) * 2 + 1)
      Res2(n, c + 3) = sArr2(i, n * 2)
    Next n
  Next i

  With Sheets("So lieu")
    'Ket qua 1
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 10 Then .Range("A11:E" & eRow).Clear
    eRow = UBound(Res) + 6
    If eRow > 10 Then
      .Range("A7:B10").Copy .Range("A11:E" & eRow)
    End If
    .Range("A7:A" & eRow) = aTDdong
    .Range("C7:E" & eRow) = Res
    .Range("C7:E" & eRow).Borders.LineStyle = 1
    'Ket qua 2
    eCol = .Cells(6, 10000).End(xlToLeft).Column
    If eCol > 10 Then .Range("K5", .Cells(15, eCol)).Clear
    eCol = UBound(Res2, 2) + 6
    If eCol > 10 Then
      .Range("G5:J6").Copy .Range("K5", .Cells(6, eCol))
    End If
    .Range("G5", .Cells(5, eCol)) = aTDcot
    .Range("G7", .Cells(15, eCol)) = Res2
    .Range("G5", .Cells(15, eCol)).Borders.LineStyle = 1
  End With
End Sub

Hơi rối

Chân thành cám ơn bác Hiếu CD