Chuyển dữ liệu từ hàng ngang thành hàng dọc và thêm dòng

[RachelS2BB]

Hiện tại mình đang gặp phải vấn đề như sau:
Dữ liệu mình đang có được sắp xếp theo dạng cột:


Và mình muốn chuyển đổi dữ liệu thành dạng ngang như thế này:

Dữ liệu mình cần xử lý tương đối lớn thì không biết có cách nào có thể làm được như vậy không?
Mình có đính kèm file ví dụ để mọi người rõ.
Mong mọi người giúp đỡ. Thanks all.

 

[lameco411]

Hiện tại mình đang gặp phải vấn đề như sau:
Dữ liệu mình đang có được sắp xếp theo dạng cột:
View attachment 204973

Và mình muốn chuyển đổi dữ liệu thành dạng ngang như thế này:
View attachment 204974
Dữ liệu mình cần xử lý tương đối lớn thì không biết có cách nào có thể làm được như vậy không?
Mong mọi người giúp đỡ. Cảm ơn all.

Gửi file lên làm cho tiện bạn

 

[RachelS2BB]

Vì dữ liệu công ty nên không public được bạn ơi. Bạn có cách nào chỉ mình với.

 

[be_09]

Vì dữ liệu công ty nên không public được bạn ơi. Bạn có cách nào chỉ mình với.

Sao bạn không biết làm File với dữ liệu giả định gần giống với thực tế rồi gửi lên để người giúp có cái mà thử và lường trước những trường hợp có thể sảy ra.

 

[saobekhonglac]

Vì dữ liệu công ty nên không public được bạn ơi. Bạn có cách nào chỉ mình với.

Đổi bằng dữ liệu khác chứ miễn cấu trúc giống là được rồi

 

[lameco411]

Thử cái này xem

Sub doc_ngang()
Dim sh As Worksheet
Dim shn As Worksheet
Dim d As Long
Dim dn As Long
Dim n As Long
Dim i As Long
Dim j As Long
Set sh = Sheets("Ngang")
Set shn = Sheets("Doc")
d = sh.Range("A" & Rows.Count).End(3).Row
For i = 1 To d
  n = Application.WorksheetFunction.CountA(sh.Range(i & ":" & i))
  dn = shn.Range("A" & Rows.Count).End(3).Row + 1
  For j = 1 To n - 1
    shn.Range("A" & dn).Offset(j - 1, 0).Value = sh.Range("A" & i).Value
    shn.Range("B" & dn).Offset(j - 1, 0).Value = sh.Range("A" & i).Offset(0, j).Value
  Next j
Next i
End Sub

Bạn đặt tên 2 sheet lại cho phù hợp nha:

 

[phulien1902]

Hiện tại mình đang gặp phải vấn đề như sau:
Dữ liệu mình đang có được sắp xếp theo dạng cột:
View attachment 204973

Và mình muốn chuyển đổi dữ liệu thành dạng ngang như thế này:
View attachment 204974
Dữ liệu mình cần xử lý tương đối lớn thì không biết có cách nào có thể làm được như vậy không?
Mong mọi người giúp đỡ. Cảm ơn all.

Thử:

Option Explicit
Sub abc()
    Dim a, b(), i&, j&, k&
    With Sheets(1)
        a = .Range("A1", .Range("A1").CurrentRegion).Value
    End With
    ReDim b(1 To UBound(a) * UBound(a, 2), 1 To 2)
    For i = 1 To UBound(a)
        For j = 2 To UBound(a, 2)
            If a(i, j) > 0 Then
                k = k + 1
                b(k, 1) = a(i, 1)
                b(k, 2) = a(i, j)
            End If
        Next
    Next
    With Sheets(2)
        .UsedRange.ClearContents
        .Range("A1:B1").Resize(k).Value = b
    End With
End Sub

 

[RachelS2BB]

Mình gửi file Test nhé. Trong file có 97 dòng và 8 cột (1 cột Code và 7 cột Value) -> cần chuyển thành 679 dòng và 2 cột (Code và Value). Mong mọi người giúp đỡ nhé. Cảm ơn mọi người.

 

[phulien1902]

Thử với 1 việc duy nhất là bấm nút:

Option Explicit
Sub abc2()
    Dim a, b(), i&, j&, k&
    With Sheets("Input")
        a = .Range("A4", .Range("A4").End(xlDown)).Resize(, 8).Value
    End With
    ReDim b(1 To UBound(a) * UBound(a, 2), 1 To 2)
    For i = 1 To UBound(a)
        For j = 2 To UBound(a, 2)
            If a(i, j) > 0 Then
                k = k + 1
                b(k, 1) = a(i, 1)
                b(k, 2) = a(i, j)
            End If
        Next
    Next
    With Sheets("Output")
        .UsedRange.ClearContents
        .Range("A1:B1").Resize(k).Value = b
    End With
End Sub

 

[HieuCD]

Thử với 1 việc duy nhất là bấm nút:

Option Explicit
Sub abc2()
    Dim a, b(), i&, j&, k&
    With Sheets("Input")
        a = .Range("A4", .Range("A4").End(xlDown)).Resize(, 8).Value
    End With
    ReDim b(1 To UBound(a) * UBound(a, 2), 1 To 2)
    For i = 1 To UBound(a)
        For j = 2 To UBound(a, 2)
            If a(i, j) > 0 Then
                k = k + 1
                b(k, 1) = a(i, 1)
                b(k, 2) = a(i, j)
            End If
        Next
    Next
    With Sheets("Output")
        .UsedRange.ClearContents
        .Range("A1:B1").Resize(k).Value = b
    End With
End Sub

Cột đầu tiên có số 0 không biết có lấy không

 

[phulien1902]

Cột đầu tiên có số 0 không biết có lấy không

Nếu không lấy thì cho thêm 1 điều kiện nữa bác:

If a(i, 1) > 0

 

[HieuCD]

Nếu không lấy thì cho thêm 1 điều nữa bác:

If a(i, 1) > 0

Mình nói không rỏ, cột đầu tiên của "j", a(i, j) có giá trị 0
For j = 2 To UBound(a, 2)
If a(i, j) > 0 Then