VBA chuyển dữ liệu ma trận thành từng cột

[haup299]

Xin chào các bạn
Mình muốn chuyển dữ liệu ngang và dọc thành từng cột qua 1 sheet khác
Nếu copy thủ công thì rất lâu.
Chi tiết mình có ghi trong file
Rất mong được sự giúp đỡ của các bạn
Cảm ơn các bạn

 

[tam888]

Xin chào các bạn
Mình muốn chuyển dữ liệu ngang và dọc thành từng cột qua 1 sheet khác
Nếu copy thủ công thì rất lâu.
Chi tiết mình có ghi trong file
Rất mong được sự giúp đỡ của các bạn
Cảm ơn các bạn

Lập công thức là được rồi, xem hàm Index để biết cách

 

[be_09]

Xin chào các bạn
Mình muốn chuyển dữ liệu ngang và dọc thành từng cột qua 1 sheet khác
Nếu copy thủ công thì rất lâu.
Chi tiết mình có ghi trong file
Rất mong được sự giúp đỡ của các bạn
Cảm ơn các bạn

Thử code cùi bắp này (cột G chẳng hiểu).

Sub Copy_Paste()
    Sheet1.Range("A3").CurrentRegion.Offset(2).Copy
    With Sheet2
        .Range("A1").PasteSpecial Paste:=xlPasteValues
        .Range("B:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        .Range("F:K,M:BN").EntireColumn.Delete
    End With
End Sub

 

[snow25]

Xin chào các bạn
Mình muốn chuyển dữ liệu ngang và dọc thành từng cột qua 1 sheet khác
Nếu copy thủ công thì rất lâu.
Chi tiết mình có ghi trong file
Rất mong được sự giúp đỡ của các bạn
Cảm ơn các bạn

Bạn xem code nhé.

Sub chuyendulieu()
Dim arr, arr1
Dim a As Long, b As Long, i As Long, j As Long
Dim dk As Long
With Sheets("DATA")
     arr = .Range("A2:BN46").Value
     ReDim arr1(1 To UBound(arr, 1) * UBound(arr, 2), 1 To 7)
End With
     For i = 12 To UBound(arr, 2)
         For j = 3 To UBound(arr, 1)
            If arr(j, 2) <> Empty Then
             a = a + 1
             arr1(a, 1) = arr(j, 1)
             arr1(a, 2) = arr(j, 2)
             arr1(a, 3) = arr(j, 3)
             arr1(a, 4) = arr(j, 4)
             arr1(a, 5) = arr(j, 5)
             arr1(a, 6) = arr(j, i)
             arr1(a, 7) = arr(1, i)
            End If
         Next j
    Next i
With Sheets("USE")
     b = .Range("I" & Rows.Count).End(xlUp).Row
     If b > 2 Then .Range("I2:O" & b).ClearContents
     If a Then .Range("I2").Resize(a, 7).Value = arr1
End With
End Sub

 

[haup299]

Bạn xem code nhé.

Sub chuyendulieu()
Dim arr, arr1
Dim a As Long, b As Long, i As Long, j As Long
Dim dk As Long
With Sheets("DATA")
     arr = .Range("A2:BN46").Value
     ReDim arr1(1 To UBound(arr, 1) * UBound(arr, 2), 1 To 7)
End With
     For i = 12 To UBound(arr, 2)
         For j = 3 To UBound(arr, 1)
            If arr(j, 2) <> Empty Then
             a = a + 1
             arr1(a, 1) = arr(j, 1)
             arr1(a, 2) = arr(j, 2)
             arr1(a, 3) = arr(j, 3)
             arr1(a, 4) = arr(j, 4)
             arr1(a, 5) = arr(j, 5)
             arr1(a, 6) = arr(j, i)
             arr1(a, 7) = arr(1, i)
            End If
         Next j
    Next i
With Sheets("USE")
     b = .Range("I" & Rows.Count).End(xlUp).Row
     If b > 2 Then .Range("I2:O" & b).ClearContents
     If a Then .Range("I2").Resize(a, 7).Value = arr1
End With
End Sub

cảm ơn bạn nhiều nhé