Sub Demo1()
Const C = "I:L"
Dim V(1), W(), R, N%, L&
If [OR(A4=0,E4=0)] Then Beep: Exit Sub
V(0) = Range("A4", [A3].End(xlDown)(1, 3))
V(1) = Range("E4", [E3].End(xlDown)(1, 3))
ReDim W(1 To (UBound(V(0)) + UBound(V(1))) * 2, 1 To 4)
R = Array(1, 1)
With Columns(C).Rows(2).CurrentRegion.Rows
If .Count > 2 Then .Item("3:" & .Count).Clear
End With
Do
N = -(V(1)(R(1), 3) < V(0)(R(0), 3))
L = L + 1
W(L, 1) = V(N)(R(N), 3): W(L, 2) = V(0)(R(0), 1): W(L, 3) = V(1)(R(1), 1): W(L, 4) = W(L, 1)
For N = 0 To 1
V(N)(R(N), 3) = V(N)(R(N), 3) - W(L, 1)
If CCur(V(N)(R(N), 3)) = 0 Then If R(N) < UBound(V(N)) Then R(N) = R(N) + 1 Else V(N)(R(N), 3) = 0
Next
Loop While V(0)(R(0), 3) * V(1)(R(1), 3)
N = -(V(1)(R(1), 3) > 0)
If V(N)(R(N), 3) Then
Do
L = L + 1
W(L, 1 + N * 2) = V(N)(R(N), 3 - N * 2): W(L, 2 + N * 2) = V(N)(R(N), 1 + N * 2)
R(N) = R(N) + 1
Loop Until R(N) > UBound(V(N))
End If
With Rows(4).Resize(L).Columns(C)
.Borders.Weight = 2: .BorderAround , 3
.Item("B:C").HorizontalAlignment = xlCenter
Union(.Item(1), .Item(4)).NumberFormat = " # ###_W"
.Value = W
End With
With Rows(4 + L).Columns(C)
With Union(.Item(1), .Item(4)): .BorderAround , 3: .FormulaR1C1 = "=SUM(R[-" & L & "]C:R[-1]C)": End With
.Item(1).Borders(10).Weight = 2: .Item(4).Borders(7).Weight = 2
End With
End Sub