Here is the update to my code.
Sub ReArngeStnAry()
Dim wd As Worksheet, wc As Worksheet, a, b
Dim k&, mx&, j&, g&, i&, e&, n&, s&
Set wd = Sheets("Distribution")
Set wc = Sheets("Calculation")
Application.ScreenUpdating = False
a = Range("DA14:DA" & wc.Cells(Rows.Count, "DA").End(xlUp).Row)
s = WorksheetFunction.Sum(wd.Range("X7:X" & wd.Cells(Rows.Count, "X").End(xlUp).Row))
ReDim b(1 To s, 1 To 3)
g = 1: k = 1: n = 1
For i = 7 To wd.Cells(Rows.Count, "X").End(xlUp).Row
k = 1
If wd.Cells(i, "F").Value = wd.Cells(i, "X").Value Then
For j = 1 To wd.Cells(i, "X").Value
b(g, 1) = k
b(g, 2) = wc.Cells(g - e + 13, "DA").Value
b(g, 3) = n
k = k + 1: g = g + 1: n = n + 1
Next
Else
k = 1
mx = wd.Cells(i, "F").Value
For j = 1 To mx
b(g, 1) = k
b(g, 2) = wc.Cells(g - e + 13, "DA").Value
b(g, 3) = n
k = k + 1: g = g + 1: n = n + 1
Next
k = 1
For j = mx + 1 To wd.Cells(i, "X").Value
b(g, 1) = k
b(g, 2) = ""
b(g, 3) = n
k = k + 1: g = g + 1: e = e + 1: n = n + 1
Next
End If
Next
wc.[DG14].Resize(s, 3) = b
Application.ScreenUpdating = True
End Sub
Bookmarks