Option Explicit
'https://www.mrexcel.com/board/threads/all-combinations-of-multiple-columns-without-duplicates.1106189/page-2#post-5799308
Sub subCheckForDupesAndUniques()
'Examines the 'Full Data Set' worksheets and shows duplciates and uniques on the
' 'Dupes' and 'Unique Names' worksheets. Review thes woresheets and make needed
' corrections to 'Full Data Set'
Dim aryConcat As Variant
Dim lIndexCol As Long
Dim lIndexRow As Long
Dim lLastRow As Long
Dim lLastCol As Long
Dim sType As String
Dim lSpacePos As Long
Dim lWriteRow As Long
Dim sNameTeam As String
Dim varK As Variant, varI As Variant, varTemp As Variant, lIndex As Long
Dim oSD As Object
Set oSD = CreateObject("Scripting.Dictionary")
oSD.CompareMode = vbTextCompare
Worksheets("Unique Names").UsedRange.Cells.Clear
Worksheets("Dupes").UsedRange.Cells.Clear
lWriteRow = 1
Worksheets("Dupes").Cells(lWriteRow, 1).Resize(1, 5).Value = Array("Name", "Cost", "FPTS", "Type", "Row")
With Worksheets("Full Data Set")
lLastCol = .Cells(1#, Columns.Count).End(xlToLeft).Column
For lIndexCol = 1 To lLastCol Step 3
lLastRow = .Cells(.Rows.Count, lIndexCol).End(xlUp).Row
sType = Trim(.Cells(1, lIndexCol))
lSpacePos = InStr(sType, " ")
If lSpacePos > 0 Then sType = Left(sType, lSpacePos - 1)
For lIndexRow = 2 To lLastRow
sNameTeam = Trim(.Cells(lIndexRow, lIndexCol).Value)
oSD.Item(sNameTeam) = oSD.Item(sNameTeam) + 1
aryConcat = Array(sNameTeam, _
Trim(.Cells(lIndexRow, lIndexCol + 1).Value), _
Trim(.Cells(lIndexRow, lIndexCol + 2).Value), _
sType, lIndexRow)
lWriteRow = lWriteRow + 1
Worksheets("Dupes").Cells(lWriteRow, 1).Resize(1, 5).Value = aryConcat
Next
Next
End With
If oSD.Count > 0 Then
ReDim varTemp(1 To 2, 1 To oSD.Count)
varK = oSD.keys: varI = oSD.Items
For lIndex = 1 To oSD.Count
varTemp(1, lIndex) = varK(lIndex - 1): varTemp(2, lIndex) = varI(lIndex - 1)
Next
'Write to Worksheet
Worksheets("Unique Names").Range("A1").Resize(1, 3).Value = Array("Name", "Count", "Code")
Worksheets("Unique Names").Range("A2").Resize(oSD.Count, 2).Value = Application.Transpose(varTemp)
ActiveWorkbook.Worksheets("Unique Names").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Unique Names").Sort.SortFields.Add Key:=Range( _
"A2:A" & oSD.Count + 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Unique Names").Sort
.SetRange Range("A1:C" & oSD.Count + 1)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End If
With ActiveWorkbook.Worksheets("Dupes")
lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range( _
"A2:A" & lLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Dupes").Sort
.SetRange Range("A1:E" & lLastRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
Application.Goto Worksheets("Dupes").Range("A1"), Scroll:=True
AlternateRangeRowColorBasedOnColumnChange
End Sub
Sub AlternateRangeRowColorBasedOnColumnChange()
'Alternate row colors as column lCheckCol changes
'This is best used if the range is sorted on column lCheckCol
'Revised 2021-12-11
Const lCheckCol As Long = 1
Dim rngRow As Range
Dim rngDatabase As Range
Dim strPrevious As String
Dim intColor1 As Integer
Dim intColor2 As Integer
Dim intCurrentColor As Integer
Dim dblChecked As Double
Set rngDatabase = ActiveSheet.UsedRange
strPrevious = ""
intColor1 = 15
intColor2 = 2
strPrevious = Cells(rngDatabase.Rows(1).Row, lCheckCol).Value
'Clear existing fill colors
rngDatabase.Cells.Interior.ColorIndex = intColor1
For Each rngRow In rngDatabase.Rows
If Cells(rngRow.Row, lCheckCol).Value <> strPrevious Then
If intCurrentColor = intColor1 Then
intCurrentColor = intColor2
Else
intCurrentColor = intColor1
End If
strPrevious = Cells(rngRow.Row, lCheckCol).Value
End If
rngRow.Cells.Interior.ColorIndex = intCurrentColor
Next rngRow
Set rngDatabase = Nothing
End Sub
Sub subProcess()
Const lCostMax As Long = 50001
Const sngFPTSMax As Single = 200.01
Dim aryData As Variant
Dim aryIndex(1 To 9) As Variant
Dim lCost As Long
Dim sngFPTS As Single
Dim lCol As Long
Dim lRow As Long
Dim lIndex As Long
Dim lCarry As Long
Dim sName As String
Dim lOffset As Long
Dim lWriteRow As Long
Dim lLastPosRow As Long
Dim lLastRow As Long
Dim dblChecked As Double
Dim sStatus As String
Dim dteTime As Date
Dim lGoodCount As Long
Dim oSD As Object
Set oSD = CreateObject("Scripting.Dictionary")
oSD.CompareMode = vbTextCompare
Worksheets("Output").Range("A1").Resize(1, 29).Value = Array("QB NAME", "QB COST", "QB FPTS", "RB1 NAME", "RB1 COST", "RB1 FPTS", "RB2 NAME", "RB2 COST", "RB2 FPTS", "WR1 NAME", "WR1 COST", "WR1 FPTS", "WR2 NAME", "WR2 COST", "WR2 FPTS", "WR3 NAME", "WR3 COST", "WR3 FPTS", "TE NAME", "TE COST", "TE FPTS", "FLEX NAME", "FLEX COST", "FLEX FPTS", "DEFENSE NAME", "DEFENSE COST", "DEFENSE FPTS", "TOTAL COST", "TOTAL FPTS")
Worksheets("Dupes").Range("A1").Resize(1, 5).Value = Array("Name", "Cost", "FPTS", "Type", "Row")
Worksheets("Unique Names").Range("A1").Resize(1, 2).Value = Array("Name", "Count")
Worksheets("Position").Range("A1").Resize(1, 9).Value = Array("1", "2", "3", "4", "5", "6", "7", "8", "9")
dteTime = Now()
Application.ScreenUpdating = False
aryData = Worksheets("Full Data Set").Range("A1:AA20").Value
'Initialize Indices
For lIndex = 1 To 9
aryIndex(lIndex) = 2
Next
'Restore last position
With Worksheets("Position")
lLastPosRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If lLastPosRow > 1 Then
Select Case MsgBox("Do you want to start from the last saved position?" & vbLf & vbLf & _
" Yes" & vbTab & " to start from saved position" & vbLf & _
" No" & vbTab & " to start over", vbYesNo, "Start from last save ? ")
Case vbYes
For lIndex = 1 To 9
aryIndex(lIndex) = .Cells(lLastPosRow, lIndex)
Next
End Select
End If
End With
'Next row for good output
With Worksheets("Output")
lWriteRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End With
Do
' For lIndex = 1 To 9
' Debug.Print aryIndex(lIndex);
' Next
' Debug.Print
'Calculate Next row
For lIndex = 1 To 9
lOffset = (3 * lIndex) - 2 '1,4,7,10,13,16,19,22,25
sName = aryData(aryIndex(lIndex), lOffset)
oSD.Item(sName) = oSD.Item(sName) + 1
lCost = lCost + aryData(aryIndex(lIndex), lOffset + 1)
sngFPTS = sngFPTS + aryData(aryIndex(lIndex), lOffset + 2)
Next
'Good Row?
If lCost < lCostMax And sngFPTS < sngFPTSMax And oSD.Count = 9 Then
'VBA.Beep: Stop
For lIndex = 1 To 9
With Worksheets("Output")
lOffset = (3 * lIndex) - 2 '1,4,7,10,13,16,19,22,25
.Cells(lWriteRow, lOffset).Value = aryData(aryIndex(lIndex), lOffset)
.Cells(lWriteRow, lOffset + 1).Value = aryData(aryIndex(lIndex), lOffset + 1)
.Cells(lWriteRow, lOffset + 2).Value = aryData(aryIndex(lIndex), lOffset + 2)
End With
Next
lWriteRow = lWriteRow + 1
End If
'Reset counters
lCost = 0: sngFPTS = 0: oSD.RemoveAll
'Increment Row Indices
For lIndex = 9 To 1 Step -1
If lIndex = 9 Then
aryIndex(lIndex) = aryIndex(lIndex) + 1
If aryIndex(lIndex) = 21 Then aryIndex(lIndex) = 2: lCarry = 1
Else
aryIndex(lIndex) = aryIndex(lIndex) + lCarry
lCarry = 0
If aryIndex(9) = 21 Then Exit Do
If aryIndex(lIndex) = 21 Then aryIndex(lIndex) = 2: lCarry = 1
End If
Next
DoEvents
If CapsLockOn Then
dblChecked = 0
lLastPosRow = Worksheets("Position").Cells(Rows.Count, 1).End(xlUp).Row + 1
For lIndex = 1 To 9
Worksheets("Position").Cells(lLastPosRow, lIndex) = aryIndex(lIndex)
Debug.Print aryIndex(lIndex);
dblChecked = dblChecked + (aryIndex(lIndex) - 2) * 19 ^ (9 - lIndex)
Next
lGoodCount = Worksheets("Output").Cells(Rows.Count, 1).End(xlUp).Row - 1
sStatus = Format(dblChecked, "#,###") & " Checked, " & _
lGoodCount & " met criteria (" & _
Format(Now() - dteTime, "hh:mm:ss")
Debug.Print vbTab & sStatus
Application.ScreenUpdating = True
Application.StatusBar = sStatus
'Exit if Output worksheet nearly full
If lGoodCount > 1048570 Then Exit Do
Select Case MsgBox("Do you want to continue processing or save position and exit ?" & vbLf & vbLf & _
"Turn off CapsLock then:" & vbLf & vbLf & _
" Yes" & vbTab & " Continue processing" & vbLf & _
" No" & vbTab & " Stop, save position and Exit", vbYesNo, "Continue Processing ? ")
Case vbNo
Exit Do
End Select
End If
Loop
'Update Output Total Columns
With Worksheets("Output")
lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
With .Range(.Cells(2, 28), .Cells(lLastRow, 29))
.FormulaR1C1 = "=RC[-2]+RC[-5]+RC[-8]+RC[-11]+RC[-14]+RC[-17]+RC[-20]+RC[-23]+RC[-26]"
Application.Calculate
.Value = .Value
End With
End With
Application.StatusBar = False
Application.ScreenUpdating = True
VBA.Beep
End Sub
