Option Explicit
Public EventState As Boolean
Public PageBreakState As Boolean
Public CalcState As Long
Private Sub OptimizeCode_Begin()
'
With Application
CalcState = .Calculation
EventState = .EnableEvents
PageBreakState = ActiveSheet.DisplayPageBreaks
'
.StatusBar = False
.Calculation = xlManual
.EnableEvents = False
.ScreenUpdating = False
ActiveSheet.DisplayPageBreaks = False
End With
End Sub
Private Sub OptimizeCode_End()
'
With Application
ActiveSheet.DisplayPageBreaks = PageBreakState
.EnableEvents = EventState
.Calculation = xlAutomatic
'
.ScreenUpdating = True
.StatusBar = False
End With
End Sub
Sub NameCombosV15b()
'https://www.mrexcel.com/forum/excel-questions/1106189-all-combinations-multiple-columns-without-duplicates.html
'
Dim bFoundSalary As Boolean
Dim bShowError As Boolean
Dim ComboID_Display As Boolean
Dim dteStart As Date
Dim StartTime As Date
Dim ArrayRow As Long, ArrayColumn As Long
Dim ColumnA_Row As Long, ColumnB_Row As Long, ColumnC_Row As Long
Dim ColumnD_Row As Long, ColumnE_Row As Long, ColumnF_Row As Long
Dim ColumnG_Row As Long, ColumnH_Row As Long, ColumnI_Row As Long
Dim ColumnNumber As Long
Dim currow As Long
Dim firstrow As Long, lLastRow As Long
Dim lColumnIndex As Long
Dim lFirstHSortColumn As Long, lFirstHSortColumn2 As Long
Dim lFirstHTeamCol As Long, lLastHTeamCol As Long
Dim lFirstWriteColumn As Long, lLastWriteColumn As Long
Dim lIndex As Long
Dim lIterationCount As Long, lLastIteration As Long
Dim lLastColumn As Long
Dim lLastHSortColumn As Long, lLastHSortColumn2 As Long
Dim lLastRowDeDuped As Long
Dim lLastSalaryRow As Long
Dim lLastUsedColumn As Long
Dim lRowIndex As Long
Dim lWriteColumn As Long, lWriteRow As Long
Dim MaxSalaryAllowed As Long
Dim SubArrayNumber As Long
Dim SubArrayRow As Long
Dim SubArrays As Long
Dim UboundTempArray_1 As Long, UboundTempArray_2 As Long
Dim UniqueArrayRow As Long
Dim x As Long
Dim oSD As Object
Dim cel As Range
Dim rngDataBlock As Range
Dim rngFormulaRange As Range
Dim rngReplace As Range, rngReplace2 As Range, rngReplace3 As Range
Dim rngSortRange As Range
Dim SortRowRange As Range
Dim WorksheetNameRange As Range
Dim Delimiter As String
Dim oSD_KeyString As Variant
Dim sErrorMsg As String
Dim sMissingSalary As String
Dim sOutput As String
Dim arrOut() As Variant
Dim aryDeDupe As Variant
Dim aryNames As Variant
Dim JaggedArray() As Variant
Dim keysArray As Variant
Dim NoDupeRowArray() As Variant, NoDupeRowShortenedArray() As Variant
Dim NoDupeSortedRowsArray() As Variant
Dim SalaryCalculationArray As Variant, SalaryCalcShortenedArray() As Variant
Dim SalarySheetFullArray As Variant, SalarySheetShortenedArray() As Variant
Dim TempArray As Variant
Dim UniqueSortedRowsArray As Variant, UniqueUnSortedRowsArray() As Variant
Dim UniqueWorksheetNamesArray As Variant
Dim varK As Variant
Dim WorksheetArray As Variant
Dim WorksheetColumnArray() As Variant
Dim names As Worksheet
Dim wks As Worksheet
Dim wksData As Worksheet
'
Const MaxRowsPerSubArray As Long = 1000000 ' <--- Set the MaxRowsPerSubArray
ComboID_Display = True ' <--- Set this to True or False to see/not see the ComboID column
MaxSalaryAllowed = 60000 ' <--- set this value to what you want
'
'-------------------------------------------------------------------------------------------------------------------------------
'
Call OptimizeCode_Begin
'
Set wksData = ThisWorkbook.Sheets("Worksheet")
Set names = Sheets("Salary")
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 1) Take all the names entered on the "Worksheet" (A2:Ix) sheet and check to see if all of those names also have a salary listed on the "Salary" sheet.
' If any of the names from "Worksheet" are not on the "Salary" sheet, it ends Sub. If all the names are on the salary sheet and there are corresponding
' salaries for each of those names, a pop up box will appear letting you know how many combinations to expect.
'
'Check for salary worksheet
For Each wks In ThisWorkbook.Worksheets
If wks.Name = "Salary" Then bFoundSalary = True
Next
'
If Not bFoundSalary Then
MsgBox "The workbook must contain a worksheet named 'Salary' with data starting in row 2 " & _
"that consists of column A containing each name in the name/column layout worksheet " & _
"and column B containng their salary."
'
GoTo End_Sub
End If
'
'Make sure each name has a corresponding salary entry
'Initialize the scripting dictionary
Set oSD = CreateObject("Scripting.Dictionary")
oSD.CompareMode = vbTextCompare
'
'Inventory names on the main worksheet
For Each cel In ActiveSheet.Range("A1").CurrentRegion.Offset(1, 0)
cel.Value = Trim(cel.Value)
'
If cel.Value <> vbNullString Then
oSD.Item(cel.Value) = oSD.Item(cel.Value) + 1
End If
Next
'
'Remove names on the Salary worksheet
With Worksheets("Salary")
For Each cel In .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
cel.Value = Trim(cel.Value)
'
If oSD.Exists(cel.Value) Then
oSD.Remove cel.Value
End If
Next
End With
'
'Any names not accounted for?
If oSD.Count <> 0 Then
varK = oSD.keys
'
For lIndex = LBound(varK) To UBound(varK)
sMissingSalary = sMissingSalary & ", " & varK(lIndex)
Next
'
sMissingSalary = Mid(sMissingSalary, 3)
'
sOutput = "The following names on the main worksheet do not have a corresponding entry on the 'Salary' worksheet." & vbLf & vbLf & sMissingSalary
'
MsgBox sOutput
Debug.Print sOutput
'
GoTo End_Sub
End If
'
sErrorMsg = "Ensure a Worksheet is active with a header row starting in A1" & "and names under each header entry."
'
If TypeName(ActiveSheet) <> "Worksheet" Then
bShowError = True
End If
'
If bShowError Then
MsgBox sErrorMsg, , "Problems Found in Data"
'
GoTo End_Sub
End If
'
lLastColumn = Range("A1").CurrentRegion.Columns.Count
lLastUsedColumn = ActiveSheet.UsedRange.Columns.Count
ReDim aryNames(1 To 2, 1 To lLastColumn) '1 holds the in-use entry row
'
'How many combinations? (Order does not matter)
lLastIteration = 1
'
For lColumnIndex = 1 To lLastColumn
aryNames(1, lColumnIndex) = 2
aryNames(2, lColumnIndex) = Cells(Rows.Count, lColumnIndex).End(xlUp).Row
lLastIteration = lLastIteration * (aryNames(2, lColumnIndex) - 1)
Next
'
lFirstWriteColumn = lLastColumn + 2
lLastWriteColumn = (2 * lLastColumn) + 1
'
Select Case MsgBox("Process a " & lLastColumn & " column table with " & _
lLastIteration & " possible combinations?" & vbLf & vbLf & _
"WARNING: Columns right of the input range will be erased before continuing.", vbOKCancel + vbExclamation + _
vbDefaultButton2, "Process table?")
'
Case vbCancel
GoTo End_Sub
End Select
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 2) Clear all columns to the right of Column I on the "Worksheet" sheet. Copy headers from A1:I1 on the "Worksheet" sheet to K1:S1 on the "Worksheet" sheet.
' Add header "ComboID" to T1 on the "Worksheet" sheet. Create the combinations & if there are no duplicate names in the same combination row then write the
' combination of names & lIterationCount to NoDupeRowArray.
'
dteStart = Now()
StartTime = Now()
'
Application.StatusBar = "Step 1 of 5 ... Calculating name combinations & saving combinations with no duplicate names in same combination ..."
DoEvents
'
'Clear all columns right of input range
If lLastUsedColumn > lLastColumn Then
Range(Cells(1, lLastColumn + 1), Cells(1, lLastUsedColumn)).EntireColumn.ClearContents
End If
'
' Save Worksheet data into 2D 1 based WorksheetArray
Set WorksheetNameRange = wksData.Range("A2:" & Split(Cells(1, lLastColumn).Address, "$")(1) & _
wksData.Range("A1").CurrentRegion.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row)
WorksheetArray = WorksheetNameRange
'
ReDim NoDupeRowArray(1 To lLastIteration, 1 To lLastColumn + 1) ' Set up NoDupeRowArray with rows = lLastIteration & columns 1 more than data range
'
Cells(1, lLastWriteColumn + 1).Value = "ComboID"
'
'Add Output Header
Range(Cells(1, 1), Cells(1, lLastColumn)).Copy Destination:=Cells(1, lFirstWriteColumn)
'
' Load data from 'Worksheet', each column of data will be loaded into a separate array
ReDim WorksheetColumnArray(1 To lLastColumn) ' Set the # of arrays in 'jagged' array WorksheetColumnArray
'
For ColumnNumber = 1 To lLastColumn ' Loop through the columns of 'Worksheet'
lLastRow = Cells(Rows.Count, ColumnNumber).End(xlUp).Row ' Get LastRow of the column
'
ReDim TempArray(1 To lLastRow - 1, 1 To 1) ' Set the rows & columns of 2D 1 based TempArray
WorksheetColumnArray(ColumnNumber) = TempArray ' Copy the empty 2D 1 based TempArray to WorksheetColumnArray()
'
For ArrayRow = 1 To lLastRow - 1 ' Loop through the rows of data in the column
WorksheetColumnArray(ColumnNumber)(ArrayRow, 1) = WorksheetArray(ArrayRow, ColumnNumber) ' Save the data to WorksheetColumnArray()
Next ' Loop back
Next ' Loop back
'
'Start creating combinations
lIterationCount = 0 ' Reset lIterationCount
lWriteRow = 0 ' Reset lWriteRow
'
ReDim TempArray(1 To lLastIteration, 1 To lLastColumn + 1) ' Set up TempArray with rows = lLastIteration & columns 1 more than data range
'
For ColumnA_Row = 1 To UBound(WorksheetColumnArray(1), 1) ' Loop through rows of WorksheetColumnArray(1) ... Column A
For ColumnB_Row = 1 To UBound(WorksheetColumnArray(2), 1) ' Loop through rows of WorksheetColumnArray(2) ... Column B
For ColumnC_Row = 1 To UBound(WorksheetColumnArray(3), 1) ' Loop through rows of WorksheetColumnArray(3) ... Column C
For ColumnD_Row = 1 To UBound(WorksheetColumnArray(4), 1) ' Loop through rows of WorksheetColumnArray(4) ... Column D
For ColumnE_Row = 1 To UBound(WorksheetColumnArray(5), 1) ' Loop through rows of WorksheetColumnArray(5) ... Column E
For ColumnF_Row = 1 To UBound(WorksheetColumnArray(6), 1) ' Loop through rows of WorksheetColumnArray(6) ... Column F
For ColumnG_Row = 1 To UBound(WorksheetColumnArray(7), 1) ' Loop through rows of WorksheetColumnArray(7) ... Column G
For ColumnH_Row = 1 To UBound(WorksheetColumnArray(8), 1) ' Loop through rows of WorksheetColumnArray(8) ... Column H
For ColumnI_Row = 1 To UBound(WorksheetColumnArray(9), 1) ' Loop through rows of WorksheetColumnArray(9) ... Column I
lIterationCount = lIterationCount + 1 ' Increment lIterationCount
'
' Point to the next blank row in the NoDupeRowArray
lWriteRow = lWriteRow + 1 ' Increment lWriteRow
'
' Save the combination & ComboID to TempArray
TempArray(lWriteRow, 1) = WorksheetColumnArray(1)(ColumnA_Row, 1) ' Save name from column A to TempArray
TempArray(lWriteRow, 2) = WorksheetColumnArray(2)(ColumnB_Row, 1) ' Save name from column B to TempArray
TempArray(lWriteRow, 3) = WorksheetColumnArray(3)(ColumnC_Row, 1) ' Save name from column C to TempArray
TempArray(lWriteRow, 4) = WorksheetColumnArray(4)(ColumnD_Row, 1) ' Save name from column D to TempArray
TempArray(lWriteRow, 5) = WorksheetColumnArray(5)(ColumnE_Row, 1) ' Save name from column E to TempArray
TempArray(lWriteRow, 6) = WorksheetColumnArray(6)(ColumnF_Row, 1) ' Save name from column F to TempArray
TempArray(lWriteRow, 7) = WorksheetColumnArray(7)(ColumnG_Row, 1) ' Save name from column G to TempArray
TempArray(lWriteRow, 8) = WorksheetColumnArray(8)(ColumnH_Row, 1) ' Save name from column H to TempArray
TempArray(lWriteRow, 9) = WorksheetColumnArray(9)(ColumnI_Row, 1) ' Save name from column I to TempArray
'
TempArray(lWriteRow, lLastColumn + 1) = lIterationCount ' Save lIterationCount to TempArray
Next ' Loop back
Next ' Loop back
Next ' Loop back
Next ' Loop back
Next ' Loop back
Next ' Loop back
Next ' Loop back
Next ' Loop back
Next ' Loop back
'
UboundTempArray_1 = UBound(TempArray, 1) '
UboundTempArray_2 = UBound(TempArray, 2) '
'
SubArrays = Int((UboundTempArray_1 - 1) / MaxRowsPerSubArray) + 1 ' Determine number of SubArrays needed
'
ReDim JaggedArray(1 To SubArrays) ' Set the # of SubArrays in JaggedArray
'
currow = 0 ' Reset currow
'
' Create array(s) of combinations
For SubArrayNumber = 1 To SubArrays ' Loop through SubArrays
ReDim arrOut(1 To MaxRowsPerSubArray, 1 To UboundTempArray_2 + 1) ' Reset the arrOut
'
For SubArrayRow = 1 To MaxRowsPerSubArray ' Loop through rows of arrOut
currow = currow + 1 ' Increment currow, this is the row of the TempArray
'
If currow > UboundTempArray_1 Then Exit For ' If all of the rows have been processed then exit this For loop
'
For ArrayColumn = 1 To UboundTempArray_2 ' Loop through columns of TempArray
arrOut(SubArrayRow, ArrayColumn) = TempArray(currow, ArrayColumn) ' Save column value into arrOut
Next ' Loop back
Next ' Loop back
'
JaggedArray(SubArrayNumber) = arrOut ' Save the arrOut to the JaggedArray
'
Erase arrOut '
Next ' Loop back
'
Erase TempArray '
'
' At this point, all of the MaxRowsPerSubArray row subArrays have been loaded into the JaggedArray
'
lLastUsedColumn = ActiveSheet.UsedRange.Columns.Count ' Get LastUsedColumn in the sheet
' Write each subArray to the sheet, add the formula to determine unique rows & save results back into the subArray
For SubArrayNumber = 1 To SubArrays ' Loop through SubArrays
ActiveSheet.Range("K2").Resize(UBound(JaggedArray(SubArrayNumber), 1), _
UBound(JaggedArray(SubArrayNumber), 2)) = JaggedArray(SubArrayNumber) ' Write the subArray to the sheet
'
' Add formula to each row
lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row ' Get lLastRow
'
Set rngFormulaRange = Range(Cells(2, lLastUsedColumn + 1), Cells(lLastRow, lLastUsedColumn + 1)) ' Set the Range to place formulas
'
With rngFormulaRange
.Formula = "=MODE.MULT(MATCH($" & Split(Cells(1, lFirstWriteColumn).Address, "$")(1) & "2:$" & _
Split(Cells(1, lLastUsedColumn).Address, "$")(1) & "2,$" & _
Split(Cells(1, lFirstWriteColumn).Address, "$")(1) & "2:$" & _
Split(Cells(1, lLastUsedColumn).Address, "$")(1) & "2,0))" '
Application.Calculate '
.Value = .Value '
End With
'
' Load the data with formula results back into the subArray
JaggedArray(SubArrayNumber) = ActiveSheet.Range("K2").Resize(UBound(JaggedArray(SubArrayNumber), 1), _
UBound(JaggedArray(SubArrayNumber), 2)) '
'
ActiveSheet.Range("K2").Resize(UBound(JaggedArray(SubArrayNumber), 1), _
UBound(JaggedArray(SubArrayNumber), 2)).ClearContents ' Clear the data range
Next ' Loop back
'
' Join all of the subArrays back into 1 large array, only include the rows with no duplicate names in the row
ReDim NoDupeRowArray(1 To UboundTempArray_1, 1 To UboundTempArray_2) ' Set the # of rows/columns for NoDupeRowArray
'
currow = 0 ' Reset currow
'
For SubArrayNumber = 1 To SubArrays ' Loop through the SubArrays
For SubArrayRow = 1 To UBound(JaggedArray(SubArrayNumber), 1) ' Loop through rows of each subArray in the JaggedArray
If Application.WorksheetFunction.IsNA(JaggedArray(SubArrayNumber)(SubArrayRow, UBound(JaggedArray(SubArrayNumber), 2))) Then ' If formula resulted in '#N/A' then ...
currow = currow + 1 ' Increment currow, this is the row of the NoDupeRowArray
'
For ArrayColumn = 1 To UBound(JaggedArray(SubArrayNumber), 2) - 1 ' Loop through columns of JaggedArray(SubArrayNumber)
NoDupeRowArray(currow, ArrayColumn) = JaggedArray(SubArrayNumber)(SubArrayRow, ArrayColumn) ' Save values to NoDupeRowArray
Next ' Loop back
End If
Next ' Loop back
'
Erase JaggedArray(SubArrayNumber) '
Next ' Loop back
'
Erase JaggedArray '
'
NoDupeRowArray = ReDimPreserve(NoDupeRowArray, currow, lLastColumn + 1) ' Resize NoDupeRowArray to correct the actual rows used in the array
'
Debug.Print "Create all combinations & remove rows with duplicate entries in the same row completed " & _
"in " & Format(Now() - StartTime, "hh:mm:ss") ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 3) Create a 'jagged array', which is just an array of arrays, of the remaining combinations. This us what allows us to handle
' larger amounts of combinations. Instead of trying to write them all to the sheet for sorting, we will use the jagged array
' to write amounts of combinations to the sheet that doesn't exceed the maximum amount of rows that Excel allows. We then
' sort those rows & save the result back to the jagged array, clear the sheet, write the next array to the sheet, sort the data,
' save it back to the jagged array, etc. When we are done, we combine all of those arrays in the jagged array back into
' NoDupeSortedRowsArray for further processing.
'
StartTime = Now()
'
Application.StatusBar = "Step 2 of 5 ... Sorting remaining combination rows alphabetically by row ..."
DoEvents
'
SubArrays = Int((UBound(NoDupeRowArray, 1) - 1) / MaxRowsPerSubArray) + 1 ' Determine number of SubArrays needed
'
ReDim JaggedArray(1 To SubArrays) ' Set the # of SubArrays in JaggedArray
'
currow = 0 ' Reset currow
'
' Create array(s) of combinations
For SubArrayNumber = 1 To SubArrays ' Loop through SubArrays
ReDim arrOut(1 To MaxRowsPerSubArray, 1 To UBound(NoDupeRowArray, 2)) ' Reset the arrOut
'
For SubArrayRow = 1 To MaxRowsPerSubArray ' Loop through rows of arrOut
currow = currow + 1 ' Increment currow, this is the row of the NoDupeRowArray
'
If currow > UBound(NoDupeRowArray, 1) Then Exit For ' If all of the rows have been processed then exit this For loop
'
For ArrayColumn = 1 To UBound(NoDupeRowArray, 2) ' Loop through columns of NoDupeRowArray
arrOut(SubArrayRow, ArrayColumn) = NoDupeRowArray(currow, ArrayColumn) ' Save column value into arrOut
Next ' Loop back
Next ' Loop back
'
JaggedArray(SubArrayNumber) = arrOut ' Save the arrOut to the JaggedArray
'
Erase arrOut '
Next ' Loop back
'
' At this point, all of the MaxRowsPerSubArray row subArrays have been loaded into the JaggedArray
'
' Write each subArray to the sheet, sort each row & save results back into the subArray
For SubArrayNumber = 1 To SubArrays ' Loop through SubArrays
ActiveSheet.Range("K2").Resize(UBound(JaggedArray(SubArrayNumber), 1), _
UBound(JaggedArray(SubArrayNumber), 2)) = JaggedArray(SubArrayNumber) ' Write the subArray to the sheet for sorting
'
' Sort each row
ActiveSheet.Sort.SortFields.Clear '
'
lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row ' Get lLastRow
'
Set rngSortRange = Range(Cells(2, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn + 1)) ' Set the Range to be sorted
'
For Each SortRowRange In rngSortRange.Rows ' Loop through each row of the range to be sorted
SortRowRange.Sort Key1:=SortRowRange.Cells(1, 1), Order1:=xlAscending, _
Header:=xlNo, Orientation:=xlSortRows ' Sort each row alphabetically
Next ' Loop back
'
' Load the sorted data back into the subArray
JaggedArray(SubArrayNumber) = ActiveSheet.Range("K2").Resize(UBound(JaggedArray(SubArrayNumber), 1), _
UBound(JaggedArray(SubArrayNumber), 2)) '
'
ActiveSheet.Range("K2").Resize(UBound(JaggedArray(SubArrayNumber), 1), _
UBound(JaggedArray(SubArrayNumber), 2)).ClearContents ' Clear the sort range
Next ' Loop back
'
' Join all of the sorted subArrays back into 1 large array
ReDim NoDupeSortedRowsArray(1 To UBound(NoDupeRowArray, 1), 1 To UBound(NoDupeRowArray, 2) - 1) '
'
currow = 0 ' Reset currow
'
For SubArrayNumber = 1 To SubArrays ' Loop through the SubArrays
For SubArrayRow = 1 To UBound(JaggedArray(SubArrayNumber), 1) ' Loop through rows of each subArray in the JaggedArray
currow = currow + 1 ' Increment currow, this is the row of the NoDupeSortedRowsArray
'
If currow > UBound(NoDupeSortedRowsArray, 1) Then Exit For ' If all sorted rows have been written to NoDupeSortedRowsArray then exit this loop
'
For ArrayColumn = 1 To UBound(NoDupeSortedRowsArray, 2) ' Loop through columns of NoDupeSortedRowsArray
NoDupeSortedRowsArray(currow, ArrayColumn) = _
JaggedArray(SubArrayNumber)(SubArrayRow, ArrayColumn) ' Save column value into NoDupeSortedRowsArray
Next ' Loop back
Next ' Loop back
'
Erase JaggedArray(SubArrayNumber) '
Next ' Loop back
'
Erase JaggedArray
'
Debug.Print "Sorting remaining combination rows alphabetically by row completed " & _
"in " & Format(Now() - StartTime, "hh:mm:ss") ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
' At this point, all of the MaxRowsPerSubArray sorted row subArrays have been loaded into the
' NoDupeSortedRowsArray, last column (ComboID) is now first column though due to the sorting ;)
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 4) Join names in each remaining combination row by adding a delimiter between each name and save those strings to keysArray
'
StartTime = Now()
'
Application.StatusBar = "Step 3 of 5 ... Removing duplicate sorted rows ..."
DoEvents
'
' Time to eliminate the duplicate rows in NoDupeSortedRowsArray
'
ReDim keysArray(1 To UBound(NoDupeSortedRowsArray, 1), 1 To 1) ' Set # of rows/columns of keysArray
'
' Combine each name in each row, separated by a Delimiter, to oSD_KeyString
For ArrayRow = LBound(NoDupeSortedRowsArray, 1) To UBound(NoDupeSortedRowsArray, 1) ' Loop through rows of NoDupeSortedRowsArray
oSD_KeyString = "" ' Erase 'oSD_KeyString'
Delimiter = "" ' Erase 'Delimiter' of NoDupeSortedRowsArray
For ArrayColumn = LBound(NoDupeSortedRowsArray, 2) + 1 To UBound(NoDupeSortedRowsArray, 2) ' Loop through name columns of NoDupeSortedRowsArray
oSD_KeyString = oSD_KeyString & Delimiter & NoDupeSortedRowsArray(ArrayRow, ArrayColumn) ' Save names from NoDupeSortedRowsArray row, separated by Delimiter, into oSD_KeyString
Delimiter = Chr(2)
Next ' Loop back
keysArray(ArrayRow, 1) = " " & Delimiter & oSD_KeyString ' Save oSD_KeyString to keysArray
oSD(oSD_KeyString) = True
Next ' Loop back
'
'-------------------------------------------------------------------------------------------------------
'
' 5) Save unique strings of names in the keysArray to UniqueSortedRowsArray
'
ReDim UniqueSortedRowsArray(LBound(NoDupeSortedRowsArray, 1) To oSD.Count + (LBound(NoDupeSortedRowsArray, 1) - 1), _
LBound(NoDupeSortedRowsArray, 2) To UBound(NoDupeSortedRowsArray, 2) + 1) ' Set # of rows/columns of UniqueSortedRowsArray
'
currow = LBound(NoDupeSortedRowsArray, 1) - 1 ' Initialize currow
'
For ArrayRow = LBound(NoDupeSortedRowsArray, 1) To UBound(NoDupeSortedRowsArray, 1) ' Loop through rows of NoDupeSortedRowsArray
If Not oSD.Exists(keysArray(ArrayRow, 1)) Then ' If this is a unique sorted name row then ...
oSD.Add keysArray(ArrayRow, 1), "" ' Add it to the dictionary
'
currow = currow + 1 ' Increment currow
UniqueSortedRowsArray(currow, UBound(UniqueSortedRowsArray, 2)) = _
NoDupeSortedRowsArray(ArrayRow, 1) ' Save the combination # to UniqueSortedRowsArray
'
For ArrayColumn = LBound(NoDupeSortedRowsArray, 2) + 1 To UBound(NoDupeSortedRowsArray, 2) ' Loop through columns of NoDupeSortedRowsArray
UniqueSortedRowsArray(currow, ArrayColumn - 1) = _
NoDupeSortedRowsArray(ArrayRow, ArrayColumn) ' Copy value to UniqueSortedRowsArray
Next ' Loop back
'
oSD(keysArray(ArrayRow, 1)) = False ' Flag this row as not unique flag this key as copied
End If
Next ' Loop back
Set oSD = CreateObject("Scripting.Dictionary") ' Erase contents of dictionary
Set oSD = Nothing ' Delete the dictionary
Erase keysArray '
'
UniqueSortedRowsArray = ReDimPreserve(UniqueSortedRowsArray, currow, UBound(UniqueSortedRowsArray, 2)) ' Correct the number of rows of UniqueSortedRowsArray
'
' At this point, UniqueSortedRowsArray has been created with sorted rows & with no duplicate rows & the ComboID has been added back
'
'-------------------------------------------------------------------------------------------------------
'
' 6) Now we need to match the ComboID in UniqueSortedRowsArray to the ComboID in NoDupeRowArray so we can
' put the names for that row back to the original order & save to UniqueUnSortedRowsArray
ReDim UniqueUnSortedRowsArray(1 To UBound(UniqueSortedRowsArray, 1), 1 To UBound(UniqueSortedRowsArray, 2)) ' Set the # of rows/columns for UniqueUnSortedRowsArray
ReDim SalaryCalculationArray(1 To UBound(UniqueSortedRowsArray, 1), 1 To UBound(UniqueSortedRowsArray, 2)) ' Set the # of rows/columns for SalaryArray
'
currow = 1 ' Initialize currow
'
For ArrayRow = LBound(NoDupeRowArray, 1) To UBound(NoDupeRowArray, 1) ' Loop through rows of NoDupeRowArray
If currow > UBound(UniqueUnSortedRowsArray, 1) Then Exit For ' If we have processed all rows then exit this For loop
If UniqueSortedRowsArray(currow, UBound(UniqueSortedRowsArray, 2)) = _
NoDupeRowArray(ArrayRow, UBound(NoDupeRowArray, 2)) Then ' If we found matching ComboID's then ...
'
For ArrayColumn = LBound(NoDupeRowArray, 2) To UBound(NoDupeRowArray, 2) - 1 ' Loop through the columns of NoDupeRowArray except for the last column
UniqueUnSortedRowsArray(currow, ArrayColumn) = NoDupeRowArray(ArrayRow, ArrayColumn) ' Save the name from the row/column to UniqueUnSortedRowsArray
Next ' Loop back
UniqueUnSortedRowsArray(currow, UBound(UniqueUnSortedRowsArray, 2)) = _
NoDupeRowArray(ArrayRow, UBound(NoDupeRowArray, 2)) ' Save the ComboID to UniqueUnSortedRowsArray
'
currow = currow + 1 ' Increment currow
End If
Next ' Loop back
'
Erase NoDupeRowArray
'
Application.StatusBar = "c0de Fails here"
On Error GoTo error_handler
'
wksData.Cells(2, lFirstWriteColumn).Resize(UBound(UniqueUnSortedRowsArray, 1), _
UBound(UniqueUnSortedRowsArray, 2)) = UniqueUnSortedRowsArray ' Display UniqueUnSortedRowsArray to 'Worksheet'
'
Debug.Print "Restoring order of the sorted names combinations completed in " & Format(Now() - StartTime, "hh:mm:ss") ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
Debug.Print "Removing duplicate sorted rows completed in " & Format(Now() - StartTime, "hh:mm:ss") ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
'-------------------------------------------------------------------------------------------------------
'
' 7) Copy data on sheet to next set of columns. Insert a column for the salary total of each row. Save the unique
' names from the 'Worksheet' into UniqueWorksheetNamesArray. Save respective data from 'Salary' sheet into
' SalarySheetShortenedArray. Replace copied names in column U:AC with the players respective
' salary data in SalarySheetShortenedArray. Sum the salaries from each of those rows & save results into
' the added Salary column.
'
StartTime = Now()
'
Application.StatusBar = "Step 4 of 5 ... Removing all combination rows with salaries > " & MaxSalaryAllowed & " ..." '
DoEvents '
'
lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row '
'
Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn + 1)).Copy _
Destination:=Cells(1, lLastWriteColumn + 2) ' Rows for SALARY ... Copy K1:T & lLastRow to U1:AD & lLastRow
lFirstHSortColumn = lLastWriteColumn + 2 ' 21 ie. column U
lLastHSortColumn = Cells(1, Columns.Count).End(xlToLeft).Column + 1 ' 31 ie. column AE
'
Columns(lLastHSortColumn - 1).Insert ' Insert column AD for the 'Salary'
'
With Worksheets("Salary") '''' SALARY
lLastSalaryRow = .Cells(.Rows.Count, 1).End(xlUp).Row '
End With
'
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare '
'
For Each cel In WorksheetNameRange ' Loop through each cell in the WorksheetNameRange
If cel <> "" Then ' If the cell is not blank then ...
If Not .Exists(cel.Value) Then ' If the value has not already been saved then ...
.Add cel.Value, cel.Value ' Save the value
End If
End If
'
UniqueWorksheetNamesArray = Application.Transpose(Array(.keys)) ' Transpose results to 2D 1 based UniqueWorksheetNamesArray
Next ' Loop back
End With
'
SalarySheetFullArray = names.Range("A2:" & _
Split(Cells(names.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column).Address, "$")(1) & lLastSalaryRow) ' Save all of the data from the 'Salary' aheet into 2D 1 based SalarySheetFullArray
'
ReDim SalarySheetShortenedArray(1 To UBound(SalarySheetFullArray, 1), 1 To UBound(SalarySheetFullArray, 2)) ' Set 2D 1 based SalarySheetShortenedArray to the same size as SalarySheetFullArray
'
currow = 0 ' Initialize currow
'
For UniqueArrayRow = 1 To UBound(UniqueWorksheetNamesArray, 1) ' Loop through the rows of UniqueWorksheetNamesArray
For ArrayRow = 1 To UBound(SalarySheetFullArray, 1) ' Loop through the rows of SalarySheetFullArray
If UniqueWorksheetNamesArray(UniqueArrayRow, 1) = SalarySheetFullArray(ArrayRow, 1) Then ' If the name from UniqueWorksheetNamesArray is found in SalarySheetFullArray then ...
currow = currow + 1 ' Increment currow
'
For lColumnIndex = 1 To UBound(SalarySheetFullArray, 2) ' Loop through the columns of SalarySheetFullArray
SalarySheetShortenedArray(currow, lColumnIndex) = SalarySheetFullArray(ArrayRow, lColumnIndex) ' Save the values to SalarySheetShortenedArray
Next ' Loop back
End If
Next ' Loop back
Next ' Loop back
'
SalarySheetShortenedArray = Application.Transpose(SalarySheetShortenedArray) ' Transpose SalarySheetShortenedArray so we can correct the size (row count)
'
ReDim Preserve SalarySheetShortenedArray(1 To UBound(SalarySheetFullArray, 2), 1 To currow) ' Set the row count to actual used rows
'
SalarySheetShortenedArray = Application.Transpose(SalarySheetShortenedArray) ' Transpose back the SalarySheetShortenedArray
'
'' lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row '
'
Set rngReplace = Range(Cells(2, lFirstHSortColumn), Cells(lLastRow, lLastHSortColumn - 2)) '
'
For lRowIndex = 1 To UBound(SalarySheetShortenedArray, 1) '
rngReplace.Replace What:=SalarySheetShortenedArray(lRowIndex, 1), _
Replacement:=SalarySheetShortenedArray(lRowIndex, 2), LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '
Next '
'
lLastRowDeDuped = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row '
'
'' lLastHTeamCol = lLastHSortColumn - 1 '
'
' Add Sum Column
Cells(1, lLastHSortColumn - 1).Value = ChrW(931) & " Salary" ' 30 ... AD
'
With Range(Cells(2, lLastHSortColumn - 1), Cells(lLastRowDeDuped, lLastHSortColumn - 1))
.FormulaR1C1 = "=SUM(RC" & lFirstHSortColumn & ":RC" & lLastHSortColumn - 2 & ")" '
Application.Calculate '
.Value = .Value '
End With
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 8) Save the 'Salary' range of data into SalaryCalculationArray. Save allowable salary rows into SalaryCalcShortenedArray.
' Match the ComboIDs for each row saved to the ComboIDs in UniqueUnSortedRowsArray so we can replace the
' respective names to the salaries.
'
SalaryCalculationArray = Range(Cells(2, lFirstHSortColumn), Cells(lLastRowDeDuped, lLastHSortColumn)) '
ReDim SalaryCalcShortenedArray(1 To UBound(SalaryCalculationArray, 1), 1 To UBound(SalaryCalculationArray, 2)) ' Set the # of rows/columns for SalaryCalcShortenedArray
'
currow = 0 ' Initialize currow
'
For ArrayRow = LBound(SalaryCalculationArray, 1) To UBound(SalaryCalculationArray, 1) ' Loop through rows of SalaryCalculationArray
If SalaryCalculationArray(ArrayRow, UBound(SalaryCalculationArray, 2) - 1) <= MaxSalaryAllowed Then ' If we have an allowable salary then ...
currow = currow + 1 ' Increment currow
'
For ArrayColumn = LBound(SalaryCalculationArray, 2) To UBound(SalaryCalculationArray, 2) ' Loop through the columns of SalaryCalculationArray
SalaryCalcShortenedArray(currow, ArrayColumn) = SalaryCalculationArray(ArrayRow, ArrayColumn) ' Save the data from the row to SalaryCalcShortenedArray
Next ' Loop back
End If
Next '
'
' Replace the individual Salary amounts with the original individual names by matching up the ComboIDs
currow = 1 ' Initialize currow
'
For ArrayRow = LBound(UniqueUnSortedRowsArray, 1) To UBound(UniqueUnSortedRowsArray, 1) ' Loop through rows of UniqueUnSortedRowsArray
If UniqueUnSortedRowsArray(ArrayRow, UBound(UniqueUnSortedRowsArray, 2)) = _
SalaryCalcShortenedArray(currow, UBound(SalaryCalculationArray, 2)) Then ' If we found matching ComboID's then ...
For ArrayColumn = LBound(UniqueUnSortedRowsArray, 2) To UBound(UniqueUnSortedRowsArray, 2) - 1 ' Loop through the columns of UniqueUnSortedRowsArray except for the last column
SalaryCalcShortenedArray(currow, ArrayColumn) = UniqueUnSortedRowsArray(ArrayRow, ArrayColumn) ' Save the name from the row/column to SalaryCalcShortenedArray
Next ' Loop back
'
currow = currow + 1 ' Increment currow
End If
Next ' Loop back
'
Erase UniqueUnSortedRowsArray
Erase SalarySheetFullArray '
Erase SalaryCalculationArray '
'
SalaryCalcShortenedArray = ReDimPreserve(SalaryCalcShortenedArray, currow - 1, UBound(SalaryCalcShortenedArray, 2)) '
'
Range(Columns(lFirstHSortColumn - 1), Columns(lLastHSortColumn - 2)).Delete ' Delete columns T:AC ... 20 thru 29
Range(Cells(2, lFirstWriteColumn), Cells(lLastRowDeDuped, lFirstHSortColumn)).ClearContents ' Erase rest of calculated data from the 'Worksheet'
'
' At this point, all criteria for deletion of combination rows have been completed
'
Cells(2, lFirstWriteColumn).Resize(UBound(SalaryCalcShortenedArray, 1), _
UBound(SalaryCalcShortenedArray, 2)) = SalaryCalcShortenedArray ' Display SalaryCalcShortenedArray to 'Worksheet'
'
Erase SalaryCalcShortenedArray '
'
' We need to swap the last 2 columns
Columns(lLastWriteColumn + 1).Insert ' Insert a blank column
Columns(lFirstHSortColumn + 1).Cut Cells(1, lLastWriteColumn + 1) ' Cut/paste the last column into the inserted column
'
Debug.Print "Remove all combinations with salaries > " & MaxSalaryAllowed & " completed " & _
"in " & Format(Now() - StartTime, "hh:mm:ss") ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 9) A projection column is added to column AW. The projections from columns AD:AL are
' calculated(summed) and entered into column AW. A "Stack" column is added to column AX and the most used team in the combinations are calculated using the
' MODE function. A "Stack POS" column is added to column AY. The players position - who consisted of the most used team are added to column AY by pulling the
' column headers associated to the corresponding player using the TEXTJOIN function. A "" Stack2" column is added to the AZ column and a "Stack2 POS" column
' is added to the BA column - Both using the similar method as first stack column.
'
StartTime = Now()
'
Application.StatusBar = "Step 5 of 5 ...Wrapping up ..." '
DoEvents '
'
lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row '
'
If lLastRow > 1 Then '
Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lFirstHSortColumn + 1) ' Rows for PROJECTION
'
lLastHSortColumn2 = Cells(1, Columns.Count).End(xlToLeft).Column ' 30 ... AD
'
Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastHSortColumn2 + 1) ' Rows for TEAM
'
lFirstHSortColumn2 = lFirstHSortColumn + 1 ' 22 ... V
lFirstHTeamCol = lLastHSortColumn2 + 1 ' 31 ... AE
lLastHTeamCol = Cells(1, Columns.Count).End(xlToLeft).Column ' 39 ... AM
'
Set rngReplace2 = Range(Cells(2, lFirstHSortColumn2), Cells(lLastRow, lLastHSortColumn2)) ' 22 ... V ... 30 ... AD
Set rngReplace3 = Range(Cells(2, lFirstHTeamCol), Cells(lLastRow, lLastHTeamCol)) ' 31 ... AE ... 39 ... AM
'
For lRowIndex = 1 To UBound(SalarySheetShortenedArray, 1) ' 1 to 37
'
'''''''''''''''''''''''''''''''''''''PROJECTION
rngReplace2.Replace What:=SalarySheetShortenedArray(lRowIndex, 1), _
Replacement:=SalarySheetShortenedArray(lRowIndex, 3), LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '
'
'
'''''''''''''''''''''''''''''''''''''TEAM
rngReplace3.Replace What:=SalarySheetShortenedArray(lRowIndex, 1), _
Replacement:=SalarySheetShortenedArray(lRowIndex, 4), LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '
Next '
'
' Add Projection Column
Cells(1, lLastHTeamCol + 1).Value = ChrW(931) & " Projection" ' 40 ... AN
' Add Team Stack Column
Cells(1, lLastHTeamCol + 2).Value = ChrW(931) & " Stack" ' 41 ... AO
' Add Team Stack Pos
Cells(1, lLastHTeamCol + 3).Value = ChrW(931) & " Stack POS" ' 42 ... AP
' Add 2nd Team Stack Column
Cells(1, lLastHTeamCol + 4).Value = ChrW(931) & " Stack2" ' 43 ... AQ
' Add 2nd Team Stack Pos
Cells(1, lLastHTeamCol + 5).Value = ChrW(931) & " Stack2 POS" ' 44 ... AR
' Filter 0-1
Cells(1, lLastHTeamCol + 6).Value = ChrW(931) & " Filter" ' 45 ... AS
' Player 1 Filter
Cells(1, lLastHTeamCol + 7).Value = ChrW(931) & " Player1" ' 46 ... AT
' Player 2 Filter
Cells(1, lLastHTeamCol + 8).Value = ChrW(931) & " Player2" ' 47 ... AU
'
With Range(Cells(2, lLastHTeamCol + 1), Cells(lLastRow, lLastHTeamCol + 1))
.FormulaR1C1 = "=SUM(RC" & lFirstHSortColumn2 & ":RC" & lLastHSortColumn2 & ")" ' Projection formula
Application.Calculate '
.Value = .Value '
End With
'
With Range(Cells(2, lLastHTeamCol + 2), Cells(lLastRow, lLastHTeamCol + 2))
.FormulaR1C1 = "=INDEX(RC" & lFirstHTeamCol & ":RC" & lLastHTeamCol & ",MODE(MATCH(RC" & _
lFirstHTeamCol & ":RC" & lLastHTeamCol & ",RC" & lFirstHTeamCol & ":RC" & lLastHTeamCol & ",0)))" ' Stack formula
Application.Calculate '
.Value = .Value '
End With
'
With Range(Cells(2, lLastHTeamCol + 3), Cells(lLastRow, lLastHTeamCol + 3))
.Formula2R1C1 = "=TEXTJOIN("","",1,IF(RC[-11]:RC[-3]=RC[-1],R1C[-11]:R1C[-3],""""))" ' Stack POS
Application.Calculate '
.Value = .Value '
End With
'
With Range(Cells(2, lLastHTeamCol + 4), Cells(lLastRow, lLastHTeamCol + 4))
.Formula2R1C1 = "=IFERROR(INDEX(RC[-12]:RC[-4],MODE(IF((RC[-12]:RC[-4]<>"""")*(RC[-12]:RC[-4]<>INDEX(RC[-12]:RC[-4],MODE(IF(RC[-12]:RC[-4]<>"""",MATCH(RC[-12]:RC[-4],RC[-12]:RC[-4],0))))),MATCH(RC[-12]:RC[-4],RC[-12]:RC[-4],0)))),"""")" ' Stack2 formula
Application.Calculate '
.Value = .Value '
End With
'
With Range(Cells(2, lLastHTeamCol + 5), Cells(lLastRow, lLastHTeamCol + 5))
.Formula2R1C1 = "=TEXTJOIN("","",1,IF(RC[-13]:RC[-5]=RC[-1],R1C[-13]:R1C[-5],""""))" '
Application.Calculate '
.Value = .Value '
End With
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 10) "Filter" column added to column BB, "Player1" column added to column BC, "Player2" column added to column BD. Nothing is calculated in these
' columns. Only Headers added. Currently not a used function for this project.
'
With Range(Cells(2, lLastHTeamCol + 6), Cells(lLastRow, lLastHTeamCol + 6)) '
End With
'
With Range(Cells(2, lLastHTeamCol + 7), Cells(lLastRow, lLastHTeamCol + 7)) '
End With
'
With Range(Cells(2, lLastHTeamCol + 8), Cells(lLastRow, lLastHTeamCol + 8)) '
End With
Else '
MsgBox "No rows qualified for further testing." '
'
GoTo End_Sub
End If
'
'-------------------------------------------------------------------------------------------------------------------------------
'
' 11) Removes all helper columns - U:AU. "Salary" column becomes column U. "Projection" column becomes column V. "Stack" column becomes column W. "Stack POS"
' column becomes column X. "Stack 2" column becomes column Y. "Stack 2 POS" column becomes column Z. Filter column becomes column AA. "Player1" Column
' becomes column AB. "Player2" column becomes column AC.. A Dialogue Box then pops open and provides combination info: Possible combinations,
' unique combinations, duplicates removed, and the time to process. Data is then autofitted to the used range and printed to the "Worksheet".
' OptimizeCode_End is then called, which is just turning back on screen updating and whatnot.
'
' Remove Salary Columns
'
Range(Columns(lFirstHSortColumn + 1), Columns(lLastHTeamCol)).Delete ' Delete columns V:AM ... 22 thru 39
'
If ComboID_Display = False Then Columns(lLastWriteColumn + 1).Delete ' Delete ComboID column if user chose not to see it
'
ActiveSheet.UsedRange.Columns.AutoFit '
'
sOutput = lLastIteration & vbTab & " possible combinations" & vbLf & _
lLastRow - 1 & vbTab & " unique name combinations" & vbLf & _
IIf(lLastRow < lLastRow, lLastRow - lLastRow & vbTab & " duplicate rows removed." & vbLf, "") & _
lLastRow - 1 & vbTab & " printed." & vbLf & vbLf & _
Format(Now() - dteStart, "hh:mm:ss") & " to process." '
'
End_Sub:
'
Debug.Print "Wrapping up completed in " & Format(Now() - StartTime, "hh:mm:ss") ' Display elapsed time for this process to the 'Immediate' window (CTRL+G) in VBE
'
Debug.Print sOutput '
MsgBox sOutput, , "Output Report" '
Call OptimizeCode_End
Exit Sub
error_handler:
MsgBox Err.Description
End Sub
Public Function ReDimPreserve(ArrayNameToResize, NewRowUbound, NewColumnUbound)
'
' Code inspired by Control Freak
'
' Preserve & Redim both dimensions for a 2D array
'
' example usage of the function:
' ArrayName = ReDimPreserve(ArrayName,NewRowSize,NewColumnSize)
' ie.
' InputArray = ReDimPreserve(InputArray,10,20)
'
Dim NewColumn As Long, NewRow As Long
Dim OldColumnLbound As Long, OldRowLbound As Long
Dim OldColumnUbound As Long, OldRowUbound As Long
Dim NewResizedArray() As Variant
'
ReDimPreserve = False
'
If IsArray(ArrayNameToResize) Then ' If the variable is an array then ...
OldRowLbound = LBound(ArrayNameToResize, 1) ' Save the original row Lbound to OldRowLbound
OldColumnLbound = LBound(ArrayNameToResize, 2) ' Save the original column Lbound to OldColumnLbound
'
ReDim NewResizedArray(OldRowLbound To NewRowUbound, OldColumnLbound To NewColumnUbound) ' Create a New 2D Array with same Lbounds as the original array
'
OldRowUbound = UBound(ArrayNameToResize, 1) ' Save row Ubound of original array
OldColumnUbound = UBound(ArrayNameToResize, 2) ' Save column Ubound of original array
'
For NewRow = OldRowLbound To NewRowUbound ' Loop through rows of original array
For NewColumn = OldColumnLbound To NewColumnUbound ' Loop through columns of original array
If OldRowUbound >= NewRow And OldColumnUbound >= NewColumn Then ' If more data to copy then ...
NewResizedArray(NewRow, NewColumn) = ArrayNameToResize(NewRow, NewColumn) ' Append rows/columns to NewResizedArray
End If
Next ' Loop back
Next ' Loop back
'
If IsArray(NewResizedArray) Then ReDimPreserve = NewResizedArray
End If
End Function
Nice work!
