Xin code xử lý dữ liệu với Packing List

[giaohk11]

Xin chào ACE trong diễn đàn,
Hôm trước mình có một file dữ liệu nhờ xử lý đã được @SA_DQ trợ giúp nhiệt tình, đã giúp cho công việc của mình nhiều. Xin cám ơn @SA_DQ nhiều.
Nay mình có mẫu packing list khác xin trợ giúp, mong ACE chia sẽ giùm đoạn code để xử lý.
Yêu cầu:
Từ dữ liệu Sheet.Allocation => chuyển dữ liệu sang Sheet.Detail. Trong đó ở Sheet.Allocation số lượng cột chứa StoreCode/DO/ Customer/ Qty là vô hạn (bắt đầu từ cột J), tùy theo từng packing list có nhiều hay ít StoreCode/DO
Xin cảm ơn ACE.

 

[BuiQuangThuan]

Từ dữ liệu Sheet.Allocation => chuyển dữ liệu sang Sheet.Detail. Trong đó ở Sheet.Allocation số lượng cột chứa StoreCode/DO/ Customer/ Qty là vô hạn (bắt đầu từ cột J), tùy theo từng packing list có nhiều hay ít StoreCode/DO
Xin cảm ơn ACE.

Thử code này coi thế nào

Option Explicit
Sub ABC()
Dim Arr(), Res(), i&, j&, iRow&, iCol&, ii&, K&
With Sheets("Allocation")
    iRow = .Range("F" & Rows.Count).End(3).Row
    iCol = .Cells(6, Columns.Count).End(1).Column
    Arr = .Range("A2").Resize(iRow - 1, iCol).Value
End With
ReDim Res(1 To UBound(Arr, 1) * (iCol - 8), 1 To 11)
For i = 6 To UBound(Arr, 1)
    For j = 10 To UBound(Arr, 2)
        If Arr(i, j) > 0 Then
            K = K + 1
            For ii = 1 To 7
                Res(K, ii) = Arr(i, ii)
            Next
            Res(K, 8) = Arr(2, j)
            Res(K, 9) = Arr(1, j)
            Res(K, 10) = Arr(5, j)
            Res(K, 11) = Arr(i, j)
        End If
    Next
Next
With Sheets("Detail")
    If K Then
        .Range("A2").Resize(10000, 11).ClearContents
        .Range("A2").Resize(K, 11).Value = Res
    End If
End With
End Sub

 

[giaohk11]

Thử code này coi thế nào

Option Explicit
Sub ABC()
Dim Arr(), Res(), i&, j&, iRow&, iCol&, ii&, K&
With Sheets("Allocation")
    iRow = .Range("F" & Rows.Count).End(3).Row
    iCol = .Cells(6, Columns.Count).End(1).Column
    Arr = .Range("A2").Resize(iRow - 1, iCol).Value
End With
ReDim Res(1 To UBound(Arr, 1) * (iCol - 8), 1 To 11)
For i = 6 To UBound(Arr, 1)
    For j = 10 To UBound(Arr, 2)
        If Arr(i, j) > 0 Then
            K = K + 1
            For ii = 1 To 7
                Res(K, ii) = Arr(i, ii)
            Next
            Res(K, 8) = Arr(2, j)
            Res(K, 9) = Arr(1, j)
            Res(K, 10) = Arr(5, j)
            Res(K, 11) = Arr(i, j)
        End If
    Next
Next
With Sheets("Detail")
    If K Then
        .Range("A2").Resize(10000, 11).ClearContents
        .Range("A2").Resize(K, 11).Value = Res
    End If
End With
End Sub

Hi @BuiQuangThuan ,
Cảm ơn anh nhiều.