dùng code như thế nào để chuyển dữ liệu ngang sang dọc

[Lê Duy Thương]

có người bạn nhờ giúp cho bảng dữ liệu chuyển từ ngang sang dọc bằng vba. nhưng do trình độ vba của tôi chưa vượt qua được cửa ABC nên đành nhờ các thầy, các anh, các bạn trợ giúp

yêu cầu kết quả đã được để trong file. do file dữ liệu rất nhiều nên tôi chỉ trích lược 1 ít dữ liệu mẫu thôi.
xin cảm ơn

lê duy thương

 

[dmtcvn]

Không Record Macro được hả bác Thương?

 

[Quang_Hải]

có người bạn nhờ giúp cho bảng dữ liệu chuyển từ ngang sang dọc bằng vba. nhưng do trình độ vba của tôi chưa vượt qua được cửa ABC nên đành nhờ các thầy, các anh, các bạn trợ giúp

yêu cầu kết quả đã được để trong file. do file dữ liệu rất nhiều nên tôi chỉ trích lược 1 ít dữ liệu mẫu thôi.
xin cảm ơn

lê duy thương

Mình cũng tham gia múa tí cho vui, may ra đúng yêu cầu

Sub ngang_doc()
Dim kq(), dl, i, ii, j, jj, c, k
dl = [A1].CurrentRegion.Value
ReDim kq(1 To UBound(dl) * UBound(dl, 2), 1 To UBound(dl, 2))
For i = 1 To UBound(dl, 2)
  For j = 1 To 8
    kq(k + j, 1) = dl(1, i)
      For ii = 1 To 8
        kq(jj + ii, 2) = dl(ii + 4, i)
      Next
      For c = 2 To 4
        kq(k + j, c + 1) = dl(c, i)
      Next
  Next
  k = k + 8:  jj = jj + 8
Next
Sheet2.[A1].Resize(k, 5) = kq
End Sub

 

[hoangvuluan]

Về cơ bản không có gì khác so với code ở bài trước, chỉ là có tổng quát hơn 1 ít - hy vọng đúng yêu cầu!

Sub h2v()
Const fCell = "A1" ' Thay bang o dau tien cua bang du lieu cho dung'
Const nCols = 3 ' So cot tao gia tri duoi dong tieu de - thay bang so thuc te cho dung'
Dim s As Worksheet
Dim r As Range, a(), i As Long, j As Long, k As Long, iK As Long, iC As Long, iR As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
    Set s = Sheet1 ' ten sheet du lieu la DATA'
    Set r = s.Range(s.Range(fCell), s.Range(fCell).End(xlDown).End(xlToRight))
    iC = r.Columns.Count
    iR = r.Rows.Count
    'Tong so dong = so_cot x so_dong_du_lieu'
    'trong do, so_dong_du_lieu = so_dong_cua_bang - so_cot_tao_gia_tri - 1 = iR - nCols - 1'
    iK = iR - nCols - 1
    ReDim a(1 To iC * iK, 1 To nCols + 2)
    For i = 1 To iC
        For j = 1 To iK
            a(iK * (i - 1) + j, 1) = r(1, i)
            a(iK * (i - 1) + j, 2) = r(j + nCols + 1, i)
        Next
        For k = 1 To nCols
            For j = 1 To iK
                a(iK * (i - 1) + j, 2 + k) = r(k + 1, i)
            Next
        Next
    Next
   
    'Thay sheet ket qua theo thuc te
    Sheet3.Cells.ClearContents
    Sheet3.Range("A5").Resize(iC * iK, nCols + 2) = a
   
    Set r = Nothing
    Set s = Nothing
    Erase a
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

 

[Lê Duy Thương]

Không Record Macro được hả bác Thương?

re cord thì được nhưng code dài lê thê nhìn thấy gớm. nên mới nhờ GPE giúp đỡ

 

[Lê Duy Thương]

code của quang hai cho kêt quả đúng theo mẫu nhưng cái CurrentRegion.Value thì khi gặp 1 cột trống sẽ không cho đúng kết quả.
kể cả code của hoàng vũ luân cũng sẽ sai nếu có 1 cột trống ở giữa. anh em giup tôi lần nữa nhé

 

[Quang_Hải]

code của quang hai cho kêt quả đúng theo mẫu nhưng cái CurrentRegion.Value thì khi gặp 1 cột trống sẽ không cho đúng kết quả.
kể cả code của hoàng vũ luân cũng sẽ sai nếu có 1 cột trống ở giữa. anh em giup tôi lần nữa nhé

Chơi kỳ quá, dữ liệu đã rắc rối vậy mà còn thêm cái cột trống nữa chứ

Sub ngang_doc()
Dim kq(), dl, i, ii, j, jj, c, k, n
dl = Sheet1.UsedRange.Value
ReDim kq(1 To UBound(dl) * UBound(dl, 2), 1 To UBound(dl, 2))
For i = 1 To UBound(dl, 2)
  n = IIf(dl(1, i) <> "", 1, 0)
  For j = 1 To 8
    kq(k + j, 1) = dl(1, i)
      For ii = 1 To 8
        kq(jj + ii, 2) = dl(ii + 4, i)
      Next
      For c = 2 To 4
        kq(k + j, c + 1) = dl(c, i)
      Next
  Next
  If n Then
    k = k + 8:  jj = jj + 8
  End If
Next
Sheet2.[A1].Resize(k, 5) = kq
End Sub