Sub Test()
Dim rng As Range, a, b, c(1 To 100000, 1 To 5), i As Long, j As Long, pb As Long, pc As Long, v3
With Sheets("Temp")
Set rng = .Range("A1").CurrentRegion
a = rng.Offset(2).Resize(, 3).Value
b = .Range("G3:H" & .Cells(.Rows.Count, "G").End(xlUp).Row).Value
pb = 1
For i = 1 To UBound(a, 1)
v3 = a(i, 3)
For j = pb To UBound(b, 1)
pc = pc + 1
c(pc, 1) = a(i, 1): c(pc, 2) = a(i, 2): c(pc, 3) = v3: c(pc, 4) = b(j, 1)
If a(i, 3) < b(j, 2) Then
c(pc, 5) = a(i, 3)
b(j, 2) = b(j, 2) - a(i, 3)
Exit For
ElseIf a(i, 3) = b(j, 2) Then
c(pc, 5) = a(i, 3)
pb = pb + 1
Exit For
Else
c(pc, 5) = b(j, 2)
a(i, 3) = a(i, 3) - b(j, 2)
pb = pb + 1
End If
Next j
If pb > UBound(b, 1) Then
pc = pc + 1
c(pc, 1) = a(i, 1): c(pc, 2) = a(i, 2): c(pc, 3) = v3
End If
Next i
End With
With Sheets.Add(after:=Sheets(Sheets.Count))
rng.Rows("1:2").Copy .Range("A1")
.Range("A3").Resize(pc, UBound(c, 2)).Value = c
With .Range("A1").CurrentRegion
.Borders.Weight = xlThin
.EntireColumn.AutoFit
End With
End With
End Sub
Bookmarks