Sub Test2()
'
Dim A_ColumnLoopCounter As Long, D_ColumnLoopCounter As Long
Dim Column_E_Array_Slot As Long
Dim CutsArrayColumnCounter As Long, CutsArrayMaxColumn As Long, CutsArrayResultsStartColumn As Long
Dim LastRowD As Long, LastRowInSheet As Long
Dim SubtractTotal As Long
Dim TableStartRow As Long
Dim DestinationSheet As String
Dim MyTableName As String, MyTableRange As String
Dim StartingValue As String
Dim Columns_AB_Array As Variant
Dim Column_D_Array As Variant, Column_E_Array As Variant
Dim CutsArray As Variant
Dim wsDestination As Worksheet
'
Set wsDestination = Sheets("Arkusz1") ' <--- Set this to the proper sheet name
MyTableName = "Tabela3" ' <--- Set this to your Table Nam
'
LastRowInSheet = wsDestination.Cells.Find("*", Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False).Row ' Find last used Row in sheet
LastRowD = wsDestination.Range("D" & Rows.Count).End(xlUp).Row ' Get Last used Row of column D
'
MyTableRange = "D2:E" & LastRowInSheet ' <--- Set this to the Range of the Table
TableStartRow = 3 ' <--- Set this to start row of data in the Table
StartingValue = wsDestination.Range("B1") ' <--- Set this to the Address of Value that will be subtracted from
'
Column_E_Array_Slot = 0 ' Initialize slot counter for Column_E_Array
CutsArrayColumnCounter = 0 ' Initialize CutsArrayColumnCounter
CutsArrayMaxColumn = 0 ' Initialize CutsArrayMaxColumn
CutsArrayResultsStartColumn = 9 ' Set start column number to display CutsArray
'
On Error Resume Next ' If Table doesn't exist then ignore error resulting from next line
wsDestination.ListObjects(MyTableName).Unlist ' Temporarily turn Table back into a Range
On Error GoTo 0 ' Resume Excel Error Handling
'
Columns_AB_Array = wsDestination.Range("A" & TableStartRow & ":B" & LastRowInSheet) ' Load data from A&B columns into 2 dimensional 1 based array RC
Column_D_Array = wsDestination.Range("D" & TableStartRow & ":D" & LastRowD) ' Load data from D column into 2 dimensional 1 based array RC
ReDim Column_E_Array(1 To LastRowD) ' Set size of Column_E_Array 1 dimensional array 1 based
ReDim CutsArray(1 To LastRowD, 1 To 50) ' Set CutsArray to a 2 dimensional 1 based oversized array
'
For D_ColumnLoopCounter = LBound(Column_D_Array) To UBound(Column_D_Array) ' Loop for the Column_D_Array
For A_ColumnLoopCounter = LBound(Columns_AB_Array) To UBound(Columns_AB_Array) ' Loop for the Columns_AB_Array
If Columns_AB_Array(A_ColumnLoopCounter, 1) = Column_D_Array(D_ColumnLoopCounter, 1) Then ' If column A value = column D value then ...
SubtractTotal = SubtractTotal + Columns_AB_Array(A_ColumnLoopCounter, 2) ' Keep total to subtract
'
CutsArrayColumnCounter = CutsArrayColumnCounter + 1 ' Increment CutsArrayColumnCounter
If CutsArrayColumnCounter > CutsArrayMaxColumn Then CutsArrayMaxColumn = CutsArrayColumnCounter ' Keep track of CutsArrayMaxColumn
CutsArray(D_ColumnLoopCounter, CutsArrayColumnCounter) = Columns_AB_Array(A_ColumnLoopCounter, 2) ' Save cut value to CutsArray
End If
Next
'
Column_E_Array_Slot = Column_E_Array_Slot + 1 ' Increment Column_E_Array_Slot counter
Column_E_Array(Column_E_Array_Slot) = StartingValue - SubtractTotal ' Save result into Column_E_Array
CutsArray(D_ColumnLoopCounter, CutsArrayColumnCounter + 1) = Column_E_Array(Column_E_Array_Slot) ' Also Save result into CutsArray
If CutsArrayColumnCounter + 1 > CutsArrayMaxColumn Then CutsArrayMaxColumn = CutsArrayColumnCounter + 1 ' If new CutsArrayMaxColumn, save it
SubtractTotal = 0 ' Reset SubtractTotal back to zero
CutsArrayColumnCounter = 0 ' Reset CutsArrayColumnCounter back to zero
Next
'
ReDim Preserve CutsArray(1 To LastRowD, 1 To CutsArrayMaxColumn) ' Resize CutsArray to actual used size
'
wsDestination.Range("E" & TableStartRow & ":E" & LastRowD) = Application.Transpose(Column_E_Array) ' Display Column_E_Array to column E
wsDestination.Range("H" & TableStartRow & ":H" & LastRowD) = Column_D_Array ' Display Column_D_Array to column H
wsDestination.Range(Cells(TableStartRow, CutsArrayResultsStartColumn), _
Cells(LastRowD, CutsArrayResultsStartColumn + CutsArrayMaxColumn - 1)) = CutsArray ' Display CutsArray to column I range
'
wsDestination.ListObjects.Add(xlSrcRange, wsDestination.Range(MyTableRange), , xlYes).Name = MyTableName ' ReCreate Table
End Sub
