Tách dòng tự động theo điều kiện bằng VBA (4 người xem)

Sub TachDong()
Dim SL(), SArr(), KTArr(), RArr(), LastRw As Long, LastRwSL As Long
Dim Dict, DictKeys
LastRw = Sheet2.[A10000].End(xlUp).Row
LastRwSL = Sheet2.[M100].End(xlUp).Row
SArr = Sheet2.Range("A2:E" & LastRw).Value
KTArr = Sheet2.Range("F2:J" & LastRw).Value
SL = Sheet2.Range("M2:N" & LastRwSL).Value
ReDim RArr(1 To LastRw * LastRwSL, 1 To 7)
Set Dict = CreateObject("Scripting.Dictionary")
For i = 1 To LastRwSL - 1
    Dict.Add SL(i, 1), SL(i, 2)
Next
DictKeys = Dict.keys
For i = 1 To LastRw - 1
    For j = 1 To 5
        If KTArr(i, j) > 0 Then
            k = k + 1
            RArr(k, 1) = k
            RArr(k, 2) = SArr(i, 2)
            RArr(k, 3) = SArr(i, 3)
            RArr(k, 4) = SArr(i, 4)
            RArr(k, 5) = SArr(i, 5)
            RArr(k, 6) = DictKeys(j - 1)
            RArr(k, 7) = Dict.Item(RArr(k, 6))
        End If
    Next
Next
Sheet3.[Q2].Resize(10000, 7).Clear
Sheet3.[Q2].Resize(k, 7).Value = RArr
End Sub

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    UnPivot = Table.UnpivotOtherColumns(Source, {"TT","Tên", "Code mới", "Tên sản phẩm", "Finish"}, "Kích thước", "Số lượng"),
    ReplaceValue = Table.ReplaceValue(UnPivot,"KT ","",Replacer.ReplaceText,{"Kích thước"}),
    Merge = Table.NestedJoin(ReplaceValue, {"Kích thước"}, TableSL, {"Kích thước"}, "Table3", JoinKind.LeftOuter),
    Expand = Table.ExpandTableColumn(Merge, "Table3", {"Số lượng"}, {"Số lượng.1"})
in
    Expand

Sub TachDong()
Dim SL(), SArr(), KTArr(), RArr(), LastRw As Long, LastRwSL As Long
Dim Dict, DictKeys
LastRw = Sheet2.[A10000].End(xlUp).Row
LastRwSL = Sheet2.[M100].End(xlUp).Row
SArr = Sheet2.Range("A2:E" & LastRw).Value
KTArr = Sheet2.Range("F2:J" & LastRw).Value
SL = Sheet2.Range("M2:N" & LastRwSL).Value
ReDim RArr(1 To LastRw * LastRwSL * 500, 1 To 7)
Set Dict = CreateObject("Scripting.Dictionary")
For i = 1 To LastRwSL - 1
    Dict.Add SL(i, 1), SL(i, 2)
Next
DictKeys = Dict.keys
For i = 1 To LastRw - 1
    For j = 1 To 5
        If KTArr(i, j) > 0 Then
            x = Dict.Item(DictKeys(j - 1))
            m = KTArr(i, j) / x
            For n = 1 To m
                k = k + 1
                RArr(k, 1) = k
                RArr(k, 2) = SArr(i, 2)
                RArr(k, 3) = SArr(i, 3)
                RArr(k, 4) = SArr(i, 4)
                RArr(k, 5) = SArr(i, 5)
                RArr(k, 6) = DictKeys(j - 1)
                RArr(k, 7) = x
            Next
        End If
    Next
Next
Sheet3.[Q2].Resize(100000, 7).Clear
Sheet3.[Q2].Resize(k, 7).Value = RArr
End Sub

Sub xyz()
  Dim aSL(), arr(), res(), SL&, D&
  Dim i&, j&, n&, c&, k&, sRow&, sRowRes&, sCol&
 
  With Sheet2
    arr = .Range("A2:J" & .Range("A1000000").End(xlUp).Row).Value
    aSL = .Range("M2", .Range("N1000000").End(xlUp)).Value
  End With
  sRow = UBound(arr) - 1: sCol = UBound(arr, 2)
 
  For j = 6 To sCol 'Tinh tong so dong ket qua
    sRowRes = sRowRes + Application.RoundUp(arr(sRow + 1, j) / aSL(j - 5, 2), 0)
  Next
  sRowRes = sRowRes + (sCol - 5) * sRow
  ReDim res(1 To sRowRes, 1 To 7)
 
  For j = 6 To sCol
    SL = aSL(j - 5, 2) ' So luong 1 dong
    For i = 1 To sRow
      If arr(i, j) > 0 Then
        D = Application.RoundUp(arr(i, j) / aSL(j - 5, 2), 0) ' So dong ket qua
        For n = 1 To D
          k = k + 1
          res(k, 1) = k
          For c = 2 To 5
            res(k, c) = arr(i, c)
          Next c
          res(k, 6) = aSL(j - 5, 1)
          If SL <= arr(i, j) Then res(k, 7) = SL Else res(k, 7) = arr(i, j)
          arr(i, j) = arr(i, j) - res(k, 7)
        Next n
      End If
    Next i
  Next j
 
  With Sheet1
    .Range("A2", .Range("G1000000").End(xlUp).Offset(1)).Clear
    .Range("A2").Resize(k, 7).Value = res
    .Range("A2").Resize(k, 7).Borders.LineStyle = 1
  End With
End Sub

Sub TachDong()
Dim SL(), SArr(), KTArr(), RArr(), LastRw As Long, LastRwSL As Long
LastRw = Sheet2.[A10000].End(xlUp).Row
LastRwSL = Sheet2.[M100].End(xlUp).Row
SArr = Sheet2.Range("A2:E" & LastRw).Value
KTArr = Sheet2.Range("F2:J" & LastRw).Value
SL = Sheet2.Range("M2:N" & LastRwSL).Value
ReDim RArr(1 To LastRw * LastRwSL * 500, 1 To 7)
For i = 1 To LastRw - 1
    For j = 1 To 5
        If KTArr(i, j) > 0 Then
            x = SL(j, 2)
            m = KTArr(i, j) \ x
            y = KTArr(i, j) Mod x
            For n = 1 To m
                k = k + 1
                RArr(k, 1) = k
                For t = 2 To 5
                    RArr(k, t) = SArr(i, t)
                Next
                RArr(k, 6) = SL(j, 1)
                RArr(k, 7) = x
            Next
            If y > 0 Then
                k = k + 1
                RArr(k, 1) = k
                For t = 2 To 5
                    RArr(k, t) = SArr(i, t)
                Next
                RArr(k, 6) = SL(j, 1)
                RArr(k, 7) = y
            End If
        End If
    Next
Next
Sheet3.[Q2].Resize(100000, 7).Clear
Sheet3.[Q2].Resize(k, 7).Value = RArr
End Sub