VBA chuyển dữ liệu từ hàng sang cột

[ads_ads]

Em có 1 bảng ví dụ như file đính kèm, giờ em muốn dùng VBA để chuyển dữ liệu từ sheet Nguon sang sheet Ketqua theo cách thức dữ liệu hàng sang dữ liệu cột.

Dữ liệu thực tế của em rất dài, khoảng 5000 hàng và 50 cột.

 

[thomtv]

Em có 1 bảng ví dụ như file đính kèm, giờ em muốn dùng VBA để chuyển dữ liệu từ sheet Nguon sang sheet Ketqua theo cách thức dữ liệu hàng sang dữ liệu cột.

Dữ liệu thực tế của em rất dài, khoảng 5000 hàng và 50 cột.

Bạn vào đây tham khảo thêm nhé:

 

[ads_ads]

Bạn vào đây tham khảo thêm nhé:

Nhưng bảng của mình dữ liệu hàng có độ dài không giống nhau, và khi chuyển sang Ketqua mình lại muốn dữ liệu liên tục. Bạn xem dùm cái file đính kèm được không?

 

[concogia]

Em có 1 bảng ví dụ như file đính kèm, giờ em muốn dùng VBA để chuyển dữ liệu từ sheet Nguon sang sheet Ketqua theo cách thức dữ liệu hàng sang dữ liệu cột.

Dữ liệu thực tế của em rất dài, khoảng 5000 hàng và 50 cột.

Một cách viết:

Public Sub Chuyen()
    Dim Vung As Range, VungChuyen As Range, I As Long, J As Long, K As Long, Mg As Variant
    Set Vung = Sheets("Nguon").Range(Sheets("Nguon").[A1], Sheets("Nguon").[A50000].End(xlUp))
    ReDim Mg(1 To Sheets("Nguon").Range("A1").CurrentRegion.Cells.Count, 1 To 2)
        For I = 1 To Vung.Rows.Count
            Set VungChuyen = Range(Vung(I), Vung(I).End(xlToRight))
                For J = 2 To VungChuyen.Columns.Count
                    K = K + 1
                    Mg(K, 1) = Vung(I): Mg(K, 2) = VungChuyen(J)
                Next J
        Next I
    [E2:F50000].ClearContents
    [E2].Resize(K, 2) = Mg
End Sub

Ở sheet "Ketqua" bấm vào đầu con mèo
Thân

 

[hanhluxubu]

xin doan code chuyen du lieu tu cot sang hang

Em xin go tieng viet khong dau nhe. Vi may tinh bi loi cai font ma e chua co dip nghi cach chinh lai no.

Doan code chuyen du lieu tu hang sang cot cua anh hay qua. Anh co the chinh lai doan code sao cho chuyen du lieu hang sang cot duoc khong ah?

Cam on anh nhieu

 

[minhquang05]

Các ace giúp em phần này với.
Xem giúp sao code chạy không đúng.
Phần màu vàng là kết quả em cần.

Em cảm ơn!

 

[ndu96081631]

Các ace giúp em phần này với.
Xem giúp sao code chạy không đúng.
Phần màu vàng là kết quả em cần.

Em cảm ơn!

Code của bạn:

Sub chuyendoi()
  Dim i As Integer
  Dim j As Integer
  Dim k As Integer
  Dim wb As Workbook
  Set wb = ThisWorkbook
  For i = 2 To 6
    For j = 2 To 4
      [COLOR=#ff0000]For k = 1 To 15
        Cells(k, 7) = Cells(1, i) & Cells(j, 1)
      Next k[/COLOR]
    Next j
  Next i
End Sub

Hãy sửa thành vầy:

Sub chuyendoi()
  Dim i As Long, j As Long, k As Long
  For i = 2 To 6
    For j = 2 To 4
     [COLOR=#0000cd] k = k + 1
      Cells(k, 7) = Cells(1, i) & Cells(j, 1)
      Cells(k, 8) = Cells(j, i)[/COLOR]
    Next j
  Next i
End Sub

Chỗ màu đỏ trong code của bạn sai, sửa lại như chỗ màu xanh

 

[Kathy Huynh]

Các anh giúp em với, tiêu chí chuyển data từ hàng ngang sang hàng dọc của em cũng như chủ thớt.

Tuy nhiên em có số lượng cột nhiều và dòng nhiều hơn. Em cũng ko biết miêu tả sao, em có đính kèm file, mong các anh giúp em ạ.

 

[vanthinh3101]

Các anh giúp em với, tiêu chí chuyển data từ hàng ngang sang hàng dọc của em cũng như chủ thớt.

Tuy nhiên em có số lượng cột nhiều và dòng nhiều hơn. Em cũng ko biết miêu tả sao, em có đính kèm file, mong các anh giúp em ạ.

Gửi bạn tham khảo:

Sub Rows2Columns()
    Dim sArr(), Res()
    Dim I As Long, J As Long, K As Long
    
    sArr() = Sheet5.Range("A1", Sheet5.Range("A1").End(xlDown)).Resize(, 8).Value
    ReDim Res(1 To UBound(sArr, 1) * UBound(sArr, 2), 1 To 4)
    
    For I = 2 To UBound(sArr, 1)
        For J = 3 To 8
            K = K + 1
            Res(K, 1) = sArr(I, 1): Res(K, 2) = sArr(I, 2)
            Res(K, 3) = sArr(1, J): Res(K, 4) = sArr(I, J)
        Next J
    Next I
    
    Sheet1.Range("J2").Resize(K, 4) = Res
    MsgBox "Done", vbInformation, "GPE"
End Sub

 

[theanhst92]

Gửi bạn tham khảo:

Sub Rows2Columns()
    Dim sArr(), Res()
    Dim I As Long, J As Long, K As Long
   
    sArr() = Sheet5.Range("A1", Sheet5.Range("A1").End(xlDown)).Resize(, 8).Value
    ReDim Res(1 To UBound(sArr, 1) * UBound(sArr, 2), 1 To 4)
   
    For I = 2 To UBound(sArr, 1)
        For J = 3 To 8
            K = K + 1
            Res(K, 1) = sArr(I, 1): Res(K, 2) = sArr(I, 2)
            Res(K, 3) = sArr(1, J): Res(K, 4) = sArr(I, J)
        Next J
    Next I
   
    Sheet1.Range("J2").Resize(K, 4) = Res
    MsgBox "Done", vbInformation, "GPE"
End Sub

bác cho em hỏi là nếu như dữ liệu hàng ban đầu có dữ liệu trùng nhau thì khi chuyển sang cột mình muốn xoá bỏ 1 dữ liệu trùng thì có thể sửa lại mã này như thế nào không ạ!

 

[vanthinh3101]

bác cho em hỏi là nếu như dữ liệu hàng ban đầu có dữ liệu trùng nhau thì khi chuyển sang cột mình muốn xoá bỏ 1 dữ liệu trùng thì có thể sửa lại mã này như thế nào không ạ!

Bạn nên lập 1 chủ đề mới, đưa dữ liệu giả định và nêu rõ yêu cầu.
Mọi người sẽ có phương án trợ giúp cho bạn ngay thôi.

 

[theanhst92]

Bạn nên lập 1 chủ đề mới, đưa dữ liệu giả định và nêu rõ yêu cầu.
Mọi người sẽ có phương án trợ giúp cho bạn ngay thôi.

em gửi file lên đây mong bác có thể giúp em sửa lại bỏ qua các mã trùng ạ!

 

[HUONGHCKT]

em gửi file lên đây mong bác có thể giúp em sửa lại bỏ qua các mã trùng ạ!

Vẫn code của bạn, tôi chỉ thêm phần chạy Dic để loại bỏ dòng trùng thôi.

 

[theanhst92]

Vẫn code của bạn, tôi chỉ thêm phần chạy Dic để loại bỏ dòng trùng thôi.

dạ em cảm ơn bác nhiều ạ. đúng như ý em rồi ạ.

 

[Ba Tê]

Vẫn code của bạn, tôi chỉ thêm phần chạy Dic để loại bỏ dòng trùng thôi.

Có thể dùng Dic ngay trong vòng lặp đầu tiên.

Sub LOCKH()
    Dim ArrDH(), KQ()
    Dim i As Long, j As Long, k As Long
    Dim Dic As Object, Txt As String
  Set Dic = CreateObject("Scripting.Dictionary")
    ArrDH() = Sheet2.Range("A4", Sheet2.Range("A4").End(xlDown)).Resize(, 37).Value
    ReDim KQ(1 To UBound(ArrDH, 1) * UBound(ArrDH, 2), 1 To 3)
     For i = 1 To UBound(ArrDH, 1)
        For j = 8 To 22
            If ArrDH(i, j) <> "" Then
                Txt = ArrDH(i, 1) & "#" & ArrDH(i, j)
                If Not Dic.Exists(Txt) Then
                        k = k + 1
                        Dic.Item(Txt) = ""
                    KQ(k, 1) = ArrDH(i, 1)
                    KQ(k, 2) = ArrDH(i, 3)
                    KQ(k, 3) = ArrDH(i, j)
                End If
            End If
        Next j
    Next i
    Sheet1.Range("A3").Resize(20000, 3).ClearContents
    Sheet1.Range("A3").Resize(k, 3) = KQ
Set Dic = Nothing
End Sub

 

[Cúc Hr]

Gửi bạn tham khảo:

Sub Rows2Columns()
    Dim sArr(), Res()
    Dim I As Long, J As Long, K As Long
   
    sArr() = Sheet5.Range("A1", Sheet5.Range("A1").End(xlDown)).Resize(, 8).Value
    ReDim Res(1 To UBound(sArr, 1) * UBound(sArr, 2), 1 To 4)
   
    For I = 2 To UBound(sArr, 1)
        For J = 3 To 8
            K = K + 1
            Res(K, 1) = sArr(I, 1): Res(K, 2) = sArr(I, 2)
            Res(K, 3) = sArr(1, J): Res(K, 4) = sArr(I, J)
        Next J
    Next I
   
    Sheet1.Range("J2").Resize(K, 4) = Res
    MsgBox "Done", vbInformation, "GPE"
End Sub

anh ơi,em có file này, em muốn chuyển dữ liệu cột (D) ở sheet2 thành hàng , anh có thể viết code cho file này giúp em được không, em cảm ơn

Bài đã được tự động gộp: 27/3/23

anh ơi,em có file này, em muốn chuyển dữ liệu cột (D) ở sheet2 thành hàng , anh có thể viết code cho file này giúp em được không, em cảm ơn

anh ơi em nhầm, em muốn chuyển dữ liệu cột (B) ở sheet2 thành hàng , anh có thể viết code cho file này giúp em được không, em cảm ơn