Chuyển dữ liệu từ dòng sang cột

[pinklove]

Em có file đính kèm, nhờ các anh/chị/thầy/cô giúp code để thực hiện chuyển data từ sheet Data sang được kết quả như sheet NB.
Ở sheet data, cột A là Source_name. Các cột sau tương ứng là các Target_name.
Các dòng ở data không phải cột nào cũng có dữ liệu, nếu cột nào trống thì bỏ qua.
Em xin cảm ơn ạ.

 

[Nhất Chi Lan]

Em có file đính kèm, nhờ các anh/chị/thầy/cô giúp code để thực hiện chuyển data từ sheet Data sang được kết quả như sheet NB.
Ở sheet data, cột A là Source_name. Các cột sau tương ứng là các Target_name.
Các dòng ở data không phải cột nào cũng có dữ liệu, nếu cột nào trống thì bỏ qua.
Em xin cảm ơn ạ.

Bạn thử cái này xem. Nhớ lưu cái file sang định dạng nào mà số dòng của nó lớn hơn 65535 í nha

Sub Chuyendulieu()
    Dim LastRow As Long, LastCol As Long
    Dim sArr, dArr, I As Long, J As Long, K As Long
With Sheets("Data")
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    If LastRow > 1 And LastCol > 1 Then
        sArr = .Range("A2:A" & LastRow).Resize(, LastCol).Value
    Else
        GoTo Thoat
    End If
End With
ReDim dArr(1 To UBound(sArr) * LastCol, 1 To 2)
For I = 1 To UBound(sArr)
    For J = 2 To UBound(sArr, 2)
        If sArr(I, J) <> Empty Then
            K = K + 1
            dArr(K, 1) = sArr(I, 1)
            dArr(K, 2) = sArr(I, J)
        End If
    Next J
Next I
With Sheets("NB")
    If K And K < Rows.Count Then
        .Range("C2", .Range("C" & Rows.Count).End(xlUp)).Resize(, 2).ClearContents
        .Range("C2").Resize(K, 2) = dArr
    End If
End With
Thoat:
End Sub

 

[pinklove]

Bạn thử cái này xem. Nhớ lưu cái file sang định dạng nào mà số dòng của nó lớn hơn 65535 í nha

Sub Chuyendulieu()
    Dim LastRow As Long, LastCol As Long
    Dim sArr, dArr, I As Long, J As Long, K As Long
With Sheets("Data")
    LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    If LastRow > 1 And LastCol > 1 Then
        sArr = .Range("A2:A" & LastRow).Resize(, LastCol).Value
    Else
        GoTo Thoat
    End If
End With
ReDim dArr(1 To UBound(sArr) * LastCol, 1 To 2)
For I = 1 To UBound(sArr)
    For J = 2 To UBound(sArr, 2)
        If sArr(I, J) <> Empty Then
            K = K + 1
            dArr(K, 1) = sArr(I, 1)
            dArr(K, 2) = sArr(I, J)
        End If
    Next J
Next I
With Sheets("NB")
    If K And K < Rows.Count Then
        .Range("C2", .Range("C" & Rows.Count).End(xlUp)).Resize(, 2).ClearContents
        .Range("C2").Resize(K, 2) = dArr
    End If
End With
Thoat:
End Sub

Cảm ơn bạn, đúng ý mình rồi ạ