Back again...
I need assistance with my macro as I am running into issues with the max rows exceeding 1,048,576.
The macros current method in order:
-writes a combination of names
-once names are written, it then copies those names into helper columns and replaces the names with a salary
-adds salary together in a new column
-sorts names in order
-removes duplicates
I have enough filters where the number of rows in the end will never exceed 1,048,576...however the macro still has to "write" the names and salaries to determine if it meets criteria. The removal of duplicates and salary over 60000 doesn't occur until after all the combinations are all written. Is there any way for me to continue with the rest of code if max rows written is reached and then loop back to start writing the combinations again... Thanks for any assistance
I need assistance with my macro as I am running into issues with the max rows exceeding 1,048,576.
The macros current method in order:
-writes a combination of names
-once names are written, it then copies those names into helper columns and replaces the names with a salary
-adds salary together in a new column
-sorts names in order
-removes duplicates
I have enough filters where the number of rows in the end will never exceed 1,048,576...however the macro still has to "write" the names and salaries to determine if it meets criteria. The removal of duplicates and salary over 60000 doesn't occur until after all the combinations are all written. Is there any way for me to continue with the rest of code if max rows written is reached and then loop back to start writing the combinations again... Thanks for any assistance
VBA Code:
Public CalcState As Long
Public EventState As Boolean
Public PageBreakState As Boolean
Sub OptimizeCode_Begin()
Application.ScreenUpdating = False
EventState = Application.EnableEvents
Application.EnableEvents = False
CalcState = Application.Calculation
Application.Calculation = xCalculationManual
PageBreakState = ActiveSheet.DisplayPageBreaks
ActiveSheet.DisplayPageBreaks = False
End Sub
Sub OptimizeCode_End()
ActiveSheet.DisplayPageBreaks = PageBreakState
Application.Calculation = CalcState
Application.EnableEvents = EventState
Application.ScreenUpdating = True
End Sub
Sub NameCombos()
'https://www.mrexcel.com/forum/excel-questions/1106189-all-combinations-multiple-columns-without-duplicates.html
Dim lLastColumn As Long
Dim lLastUsedColumn As Long
Dim aryNames As Variant
Dim lColumnIndex As Long
Dim lWriteRow As Long
Dim bCarry As Boolean
Dim lWriteColumn As Long
Dim rngWrite As Range
Dim lFirstWriteColumn As Long
Dim lLastWriteColumn As Long
Dim oFound As Object
Dim lRefColumn As Long
Dim lInUseRow As Long
Dim lCarryColumn As Long
Dim lPrint As Long
Dim lLastIteration As Long
Dim lIterationCount As Long
Dim sErrorMsg As String
Dim bShowError As Boolean
Dim lLastRow As Long
Dim lLastRowDeDuped As Long
Dim aryDeDupe As Variant
Dim s As Long
Dim sRow As Long
Dim x As Long
Dim wksData As Worksheet
Dim rngDataBlock As Range
Dim lngLastRow As Long, lngLastCol As Long
Dim sName As String
Dim bDupeName As Boolean
Dim oSD As Object
Dim rngCell As Range
Dim varK As Variant, varI As Variant, varTemp As Variant, lIndex As Long
Dim lRowIndex As Long
Dim lRowIndex2 As Long
Dim rngSortRange As Range
Dim dteStart As Date
Dim sOutput As String
Dim lFirstHSortColumn As Long
Dim lFirstHSortColumn2 As Long
Dim lFirstHTeamCol As Long
Dim firstrow As Long
Dim v
Dim lLastHTeamCol As Long
Dim currow As Long
Dim diff As Long
Dim lLastHSortColumn As Long
Dim lLastHSortColumn2 As Long
Dim lLastSalaryRow As Long
Dim rngReplace As Range
Dim wks As Worksheet
Dim bFoundSalary As Boolean
Dim sMissingSalary As String
Dim names As Worksheet
Call OptimizeCode_Begin
Application.StatusBar = False
Set wksData = ThisWorkbook.Sheets("Worksheet")
Set names = Sheets("Salary")
'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 rngCell In ActiveSheet.Range("A1").CurrentRegion.Offset(1, 0)
rngCell.Value = Trim(rngCell.Value)
If rngCell.Value <> vbNullString Then
oSD.Item(rngCell.Value) = oSD.Item(rngCell.Value) + 1
End If
Next
'Remove names on the Salary worksheet
With Worksheets("Salary")
For Each rngCell In .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
rngCell.Value = Trim(rngCell.Value)
If oSD.exists(rngCell.Value) Then
oSD.Remove rngCell.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
lRefColumn = lLastColumn + 1
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 + vbCritical + _
vbDefaultButton2, "Process table?")
Case vbCancel
GoTo End_Sub
End Select
dteStart = Now()
'Clear all columns right of input range
If lLastUsedColumn > lLastColumn Then
Range(Cells(1, lLastColumn + 1), Cells(1, lLastUsedColumn)).EntireColumn.ClearContents
End If
Cells(1, lLastWriteColumn + 1).Value = "ComboID"
'Add Output Header
Range(Cells(1, 1), Cells(1, lLastColumn)).Copy Destination:=Cells(1, lFirstWriteColumn)
'Start checking combinations
lWriteRow = 2
For lIterationCount = 1 To lLastIteration
If lIterationCount / 1000 = lIterationCount \ 1000 Then Application.StatusBar = _
lIterationCount & " / " & lLastIteration
'Reset the Dupe Name flag
bDupeName = False
'Check Active Combo for Dupe Names
'Initialize the scripting dictionary
Set oSD = CreateObject("Scripting.Dictionary")
oSD.CompareMode = vbTextCompare
'Load names into scripting dictionary
For lColumnIndex = lLastColumn To 1 Step -1
sName = Cells(aryNames(1, lColumnIndex), lColumnIndex).Value
oSD.Item(sName) = oSD.Item(sName) + 1
Next
'If there are names, and at least one duplicate, set the bDupeName flag
If oSD.Count > 0 Then
varK = oSD.keys
varI = oSD.Items
For lIndex = 1 To oSD.Count
If varI(lIndex - 1) > 1 Then
bDupeName = True: Exit For
End If
Next
End If
If Not bDupeName Then
'The current row had names and no duplicates
'Print Active Combo to the lWriteRow row
For lColumnIndex = lLastColumn To 1 Step -1
lWriteColumn = lColumnIndex + lLastColumn + 2
Set rngWrite = Range(Cells(lWriteRow, lFirstWriteColumn), Cells(lWriteRow, lLastWriteColumn))
Cells(lWriteRow, lRefColumn + lColumnIndex).Value = Cells(aryNames(1, lColumnIndex), lColumnIndex).Value
Next
'Uncomment next row to see the lIterationCount for the printed row
Cells(lWriteRow, lLastWriteColumn + 1).Value = lIterationCount
'Point to the next blank row
lWriteRow = lWriteRow + 1
End If
'Increment Counters
'Whether the line had duplicates or not, move to the next name in the
' rightmost column, if it was ag the last name, go to the first name in that column and
' move the name in the column to the left down to the next name (recursive check if THAT
' column was already using the last name for remaining columns to the left)
aryNames(1, lLastColumn) = aryNames(1, lLastColumn) + 1
If aryNames(1, lLastColumn) > aryNames(2, lLastColumn) Then
bCarry = True
lCarryColumn = lLastColumn
Do While bCarry = True And lCarryColumn > 0
aryNames(1, lCarryColumn) = 2
bCarry = False
lCarryColumn = lCarryColumn - 1
If lCarryColumn = 0 Then Exit Do
aryNames(1, lCarryColumn) = aryNames(1, lCarryColumn) + 1
If aryNames(1, lCarryColumn) > aryNames(2, lCarryColumn) Then bCarry = True
Loop
End If
'Check counter values (for debug)
' Debug.Print lWriteRow,
' For lPrint = 1 To lLastColumn
' Debug.Print aryNames(1, lPrint) & ", ";
' Next
' Debug.Print
DoEvents
Next
Application.StatusBar = "Sorting"
Application.ScreenUpdating = False
'Copy row names to right so that each copied row can be sorted alphabetically left to right
' this will allow the Excel remove duplicate fuction to remove rows that have identical names
' in all of their sorted columns.
lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastWriteColumn + 2) ''SALARY
lFirstHSortColumn = lLastWriteColumn + 2
lLastHSortColumn = Cells(1, Columns.Count).End(xlToLeft).Column
Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastHSortColumn + 1) ''PROJECTION
lFirstHSortColumn2 = lLastHSortColumn + 1
lLastHSortColumn2 = Cells(1, Columns.Count).End(xlToLeft).Column
Range(Cells(1, lFirstWriteColumn), Cells(lLastRow, lLastWriteColumn)).Copy Destination:=Cells(1, lLastHSortColumn2 + 1) ''TEAM
lFirstHTeamCol = lLastHSortColumn2 + 1
lLastHTeamCol = Cells(1, Columns.Count).End(xlToLeft).Column
'Assumes the 'Salary' worksheet has names in the column A and salaries in column B starting in row 2
'Replace HSort names with salary
With Worksheets("Salary") '''' SALARY
lLastSalaryRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
Set rngReplace = Range(Cells(2, lFirstHSortColumn), Cells(lLastRow, lLastHSortColumn))
For lRowIndex = 2 To lLastSalaryRow
rngReplace.Replace What:=Worksheets("Salary").Cells(lRowIndex, 1).Value, _
Replacement:=Worksheets("Salary").Cells(lRowIndex, 2).Value, LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Next
lLastRowDeDuped = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
'Add Sum Column
Cells(1, lLastHTeamCol + 1).Value = ChrW(931) & " Salary"
With Range(Cells(2, lLastHTeamCol + 1), Cells(lLastRowDeDuped, lLastHTeamCol + 1))
.FormulaR1C1 = "=SUM(RC" & lFirstHSortColumn & ":RC" & lLastHSortColumn & ")"
Application.Calculate
.Value = .Value
End With
lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
With wksData
.Range("A2:I26").Cut names.Range("G2")
Application.CutCopyMode = False
End With
With wksData
'Start from cell A1 (1, 1) and assign to the last row and last column
Set rngDataBlock = .Range(.Cells(1, lLastHTeamCol + 1), .Cells(lLastRow, lLastHTeamCol + 1))
End With
x = 60000
Application.DisplayAlerts = False
With rngDataBlock
.AutoFilter Field:=1, Criteria1:=">" & x
On Error Resume Next
.Range(Cells(2, lFirstWriteColumn), Cells(lLastRow, lLastHTeamCol + 9)).Delete Shift:=xlUp
End With
Application.DisplayAlerts = True
With names
.Range("G2:O26").Cut wksData.Range("A2")
Application.CutCopyMode = False
End With
'Turn off the Autofilter safely
With wksData
.AutoFilterMode = False
If .FilterMode = True Then
.ShowAllData
End If
End With
'Sort each row
Application.ScreenUpdating = False
lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
For lRowIndex = 2 To lLastRow
Set rngSortRange = Range(Cells(lRowIndex, lFirstHSortColumn), Cells(lRowIndex, lLastHSortColumn))
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=rngSortRange, _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveSheet.Sort
.SetRange rngSortRange
.Header = xlNo
.MatchCase = False
.Orientation = xlLeftToRight
.SortMethod = xlPinYin
.Apply
End With
Next
'Check for duplicate rows in HSort Columns
' Can only happen if names are duplicated within an input column
' Build aryDeDupe -- Array(1, 2, 3,...n) -- to exclude iteration # column
lLastRow = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
ReDim aryDeDupe(0 To lLastHSortColumn - lFirstHSortColumn)
lIndex = 0
For lColumnIndex = lFirstHSortColumn To lLastHSortColumn
aryDeDupe(lIndex) = CInt(lColumnIndex - lFirstWriteColumn + 1)
lIndex = lIndex + 1
Next
ActiveSheet.Cells(1, lFirstWriteColumn).CurrentRegion.RemoveDuplicates Columns:=(aryDeDupe), Header:=xlYes
'Above line won't work unless there are parens around the Columns argument ?????
lLastRowDeDuped = Cells(Rows.Count, lFirstWriteColumn).End(xlUp).Row
'''''''''''''''''''''''''''''''''''''PROJECTION
With Worksheets("Salary")
lLastSalaryRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
Set rngReplace = Range(Cells(2, lFirstHSortColumn2), Cells(lLastRow, lLastHSortColumn2))
For lRowIndex2 = 2 To lLastSalaryRow
rngReplace.Replace What:=Worksheets("Salary").Cells(lRowIndex2, 1).Value, _
Replacement:=Worksheets("Salary").Cells(lRowIndex2, 3).Value, LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Next '''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''TEAM
With Worksheets("Salary")
lLastSalaryRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
Set rngReplace = Range(Cells(2, lFirstHTeamCol), Cells(lLastRow, lLastHTeamCol))
For lRowIndex2 = 2 To lLastSalaryRow
rngReplace.Replace What:=Worksheets("Salary").Cells(lRowIndex2, 1).Value, _
Replacement:=Worksheets("Salary").Cells(lRowIndex2, 4).Value, LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Next '''''''''''''''''''''''''''
''Add Projection Column
Cells(1, lLastHTeamCol + 2).Value = ChrW(931) & " Projection"
With Range(Cells(2, lLastHTeamCol + 2), Cells(lLastRowDeDuped, lLastHTeamCol + 2))
.FormulaR1C1 = "=SUM(RC" & lFirstHSortColumn2 & ":RC" & lLastHSortColumn2 & ")"
Application.Calculate
.Value = .Value
End With
''Add Team Stack Column
Cells(1, lLastHTeamCol + 3).Value = ChrW(931) & " Stack"
With Range(Cells(2, lLastHTeamCol + 3), Cells(lLastRowDeDuped, lLastHTeamCol + 3))
.FormulaR1C1 = "=INDEX(RC" & lFirstHTeamCol & ":RC" & lLastHTeamCol & ",MODE(MATCH(RC" & lFirstHTeamCol & ":RC" & lLastHTeamCol & ",RC" & lFirstHTeamCol & ":RC" & lLastHTeamCol & ",0)))"
Application.Calculate
.Value = .Value
End With
''Add Team Stack Pos
Cells(1, lLastHTeamCol + 4).Value = ChrW(931) & " Stack POS"
With Range(Cells(2, lLastHTeamCol + 4), Cells(lLastRowDeDuped, lLastHTeamCol + 4))
.Formula2R1C1 = "=TEXTJOIN("","",1,IF(RC[-12]:RC[-4]=RC[-1],R1C[-12]:R1C[-4],""""))"
Application.Calculate
.Value = .Value
End With
''Add 2nd Team Stack Column
Cells(1, lLastHTeamCol + 5).Value = ChrW(931) & " Stack2"
With Range(Cells(2, lLastHTeamCol + 5), Cells(lLastRowDeDuped, lLastHTeamCol + 5))
.Formula2R1C1 = "=IFERROR(INDEX(RC[-13]:RC[-5],MODE(IF((RC[-13]:RC[-5]<>"""")*(RC[-13]:RC[-5]<>INDEX(RC[-13]:RC[-5],MODE(IF(RC[-13]:RC[-5]<>"""",MATCH(RC[-13]:RC[-5],RC[-13]:RC[-5],0))))),MATCH(RC[-13]:RC[-5],RC[-13]:RC[-5],0)))),"""")"
Application.Calculate
.Value = .Value
End With
''Add 2nd Team Stack Pos
Cells(1, lLastHTeamCol + 6).Value = ChrW(931) & " Stack2 POS"
With Range(Cells(2, lLastHTeamCol + 6), Cells(lLastRowDeDuped, lLastHTeamCol + 6))
.Formula2R1C1 = "=TEXTJOIN("","",1,IF(RC[-12]:RC[-4]=RC[-1],R1C[-12]:R1C[-4],""""))"
Application.Calculate
.Value = .Value
End With
'Filter 0-1
Cells(1, lLastHTeamCol + 7).Value = ChrW(931) & " Filter"
With Range(Cells(2, lLastHTeamCol + 7), Cells(lLastRowDeDuped, lLastHTeamCol + 7))
End With
'Player 1 Filter
Cells(1, lLastHTeamCol + 8).Value = ChrW(931) & " Player1"
With Range(Cells(2, lLastHTeamCol + 8), Cells(lLastRowDeDuped, lLastHTeamCol + 8))
End With
'Player 2 Filter
Cells(1, lLastHTeamCol + 9).Value = ChrW(931) & " Player2"
With Range(Cells(2, lLastHTeamCol + 9), Cells(lLastRowDeDuped, lLastHTeamCol + 9))
End With
'Remove Salary Columns
Range(Cells(2, lFirstHSortColumn), Cells(lLastRowDeDuped, lLastHTeamCol)).EntireColumn.Delete
sOutput = lLastIteration & vbTab & " possible combinations" & vbLf & _
lLastRow - 1 & vbTab & " unique name combinations" & vbLf & _
IIf(lLastRowDeDuped <> lLastRow, lLastRow - lLastRowDeDuped & vbTab & " duplicate rows removed." & vbLf, "") & _
lLastRowDeDuped - 1 & vbTab & " printed." & vbLf & vbLf & _
Format(Now() - dteStart, "hh:mm:ss") & " to process."
ActiveSheet.UsedRange.Columns.AutoFit
MsgBox sOutput, , "Output Report"
Debug.Print sOutput
End_Sub:
Call OptimizeCode_End
Application.StatusBar = False
End Sub
