I am using some code I found that generates combinations, and have made a few adjustments to fit my needs. (other calculations to help filter the data). Everything works as intended however I would like to know how I can delete rows based on cell value. What I am trying to do is delete rows before sorting to optimize how long it takes for the macro to process. If I can delete the the rows where the sum is greater than 60,000, I would save a lot of time. The sorting function takes over 40 minutes sometimes due to the amount of combinations. Then after the macro is done for example, I may only need 200-1000 combinations out of 500,000.
The sort function is highlighted in red and the sum function is highlighted in blue. Thanks for any feedback.
The sort function is highlighted in red and the sum function is highlighted in blue. Thanks for any feedback.
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 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
Call OptimizeCode_Begin
Application.StatusBar = False
'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
[COLOR=rgb(226, 80, 65)]'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[/COLOR]
'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
'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
'''''''''''''''''''''''''''''''''''''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 '''''''''''''''''''''''''''
[COLOR=rgb(44, 130, 201)]'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[/COLOR]
''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
