Option Explicit
Sub Test5()
'
Dim SubtractTotal As Double
Dim A_ColumnLoopCounter As Long, D_ColumnLoopCounter As Long
Dim B_Row_Counter As Long
Dim Column_E_Array_Slot As Long
Dim CutsArrayColumnCounter As Long, CutsArrayMaxColumn As Long, CutsArrayResultsStartColumn As Long
Dim CutsArrayRowNumber As Long
Dim LastRowD As Long, LastRowInSheet As Long
Dim MaxCutsArrayColumnNumber As Long
Dim OneDimensionCutsArrayRow As Long
Dim UniqueCutsCountStartRow As Long, UniqueCutsCountEndRow As Long
Dim TableStartRow As Long
Dim UniqueItems As Long
Dim CutsDictionary As Object
Dim CutsArrayRowString As String
Dim DestinationSheet As String
Dim MyTableName As String, MyTableRange As String
Dim StartingValue As String
Dim Columns_AB_Array As Variant, Column_D_Array As Variant, Column_E_Array As Variant
Dim CutMeasurementArray As Variant
Dim CutsArray As Variant
Dim d1Arr As Variant
Dim key As Variant
Dim OneDimensionCutsArray As Variant
Dim wsDestination1 As Worksheet, wsDestination2 As Worksheet
'
Dim Rng As Range
'
'
'' Set wsDestination1 = Sheets("Arkusz1") ' <--- Set this to the proper sheet name
Set wsDestination1 = Sheets("Sheet1") ' <--- Set this to the proper sheet name
Set wsDestination2 = Worksheets("Sheet2") ' <--- Set this to the proper sheet name
MyTableName = "Tabela3" ' <--- Set this to your Table Nam
'
LastRowInSheet = wsDestination1.Cells.Find("*", Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False).Row ' Find last used Row in sheet
LastRowD = wsDestination1.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 = wsDestination1.Range("B1") ' <--- Set this to the Address of Value that will be subtracted from
'
With Application
.DecimalSeparator = "." ' Replace the commas with decimal points
.ThousandsSeparator = "" ' Don't use thousands separator
.UseSystemSeparators = False ' Tell excel not to use the normal system separators
End With
'
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
'
Set CutsDictionary = CreateObject("Scripting.Dictionary")
'
On Error Resume Next ' If Table doesn't exist then ignore error resulting from next line
wsDestination1.ListObjects(MyTableName).Unlist ' Temporarily turn Table back into a Range
On Error GoTo 0 ' Resume Excel Error Handling
'
Columns_AB_Array = wsDestination1.Range("A" & TableStartRow & ":B" & LastRowInSheet) ' Load data from A&B columns into 2 dimensional 1 based array RC
Column_D_Array = wsDestination1.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
'
wsDestination1.Range("E" & TableStartRow & ":E" & LastRowD) = Application.Transpose(Column_E_Array) ' Display Column_E_Array to column E
wsDestination1.Range("H" & TableStartRow & ":H" & LastRowD) = Column_D_Array ' Display Column_D_Array to column H
'
With wsDestination1
.Range(.Cells(TableStartRow, CutsArrayResultsStartColumn), .Cells(LastRowD, _
CutsArrayResultsStartColumn + CutsArrayMaxColumn - 1)) = CutsArray ' Display CutsArray to column I range
End With
'
'---------------------------------------------------------------------------------------------------------------
'
ReDim OneDimensionCutsArray(1 To UBound(Column_D_Array)) ' Resize OneDimensionCutsArray to proper size
'
For CutsArrayRowNumber = LBound(Column_D_Array) To UBound(Column_D_Array) ' Loop for CutsArrayRowNumber
d1Arr = Application.Index(CutsArray, CutsArrayRowNumber, 0) ' 1d array
'
If CutsArrayRowString = "" Then ' If CutsArrayRowString = blank then ...
CutsArrayRowString = Join(d1Arr, ",") ' add cut measurement and ',' to string
Else ' Else
CutsArrayRowString = CutsArrayRowString & Join(d1Arr, ",") ' add cut measurement and ',' to string
End If
'
If Right(CutsArrayRowString, 1) = "," Then CutsArrayRowString = Left(CutsArrayRowString, Len(CutsArrayRowString) - 1) ' If string ends with',' remove it
'
OneDimensionCutsArray(CutsArrayRowNumber) = CutsArrayRowString ' Save string to OneDimensionCutsArray
CutsArrayRowString = vbNullString ' erase CutsArrayRowString
Next
'
UniqueItems = 0 ' Initialize UniqueItems counter
'
For OneDimensionCutsArrayRow = LBound(OneDimensionCutsArray) To UBound(OneDimensionCutsArray) ' OneDimensionCutsArrayRow loop
If Not CutsDictionary.Exists(OneDimensionCutsArray(OneDimensionCutsArrayRow)) Then ' If string doesn't exist in CutsDictionary then ...
CutsDictionary.Add OneDimensionCutsArray(OneDimensionCutsArrayRow), 1 ' add string to CutsDictionary
UniqueItems = UniqueItems + 1 ' increment UniqueItems counter
Else ' Else
' Increment duplicate counter
CutsDictionary.Item(OneDimensionCutsArray(OneDimensionCutsArrayRow)) = CutsDictionary.Item(OneDimensionCutsArray(OneDimensionCutsArrayRow)) + 1
End If
Next
'
UniqueCutsCountStartRow = 2 ' Establish UniqueCutsCountStartRow
UniqueCutsCountEndRow = UniqueCutsCountStartRow + UniqueItems - 1 ' Establish UniqueCutsCountEndRow
B_Row_Counter = 0 ' Initialize B_Row_Counter
CutsArrayResultsStartColumn = 3 ' Set start column number to display CutsArray
'
wsDestination2.Range("C" & UniqueCutsCountStartRow & ":C" & UniqueCutsCountEndRow).NumberFormat = "@" ' Set range to be displayed to text
'
For Each key In CutsDictionary.Keys ' CutsDictionary loop
wsDestination2.Range("B" & UniqueCutsCountStartRow + B_Row_Counter) = CutsDictionary(key) & "x" ' display cut multiples and append 'x' to end
wsDestination2.Range("C" & UniqueCutsCountStartRow + B_Row_Counter) = key ' display cut measurements in one cell
'
CutMeasurementArray = Split(Sheets("Sheet2").Range("C" & UniqueCutsCountStartRow + B_Row_Counter).Value, ",")
With wsDestination2
.Range(.Cells(UniqueCutsCountStartRow + B_Row_Counter, CutsArrayResultsStartColumn), .Cells(UniqueCutsCountStartRow + _
B_Row_Counter, CutsArrayResultsStartColumn + CutsArrayMaxColumn - 1)) = CutMeasurementArray ' display cut measurements across columns
End With
'
B_Row_Counter = B_Row_Counter + 1 ' Increment B_Row_Counter
Next
'
MaxCutsArrayColumnNumber = CutsArrayResultsStartColumn + CutsArrayMaxColumn - 1
'
With wsDestination2.Range(Split(Cells(1, CutsArrayResultsStartColumn).Address, "$")(1) & UniqueCutsCountStartRow & _
":" & Split(Cells(1, MaxCutsArrayColumnNumber).Address, "$")(1) & UniqueCutsCountEndRow) ' Format the range ...
.Replace "#N/A", "" ' Replace any '#N/A' with blank
.NumberFormat = "General" ' Convert text value back to numeric
.Value = .Value
End With
'
Application.UseSystemSeparators = True ' Restore normal separators
End Sub
