All Combinations of Multiple Columns Without Duplicates

pbornemeier

Well-known Member
Joined
May 24, 2005
Messages
3,725
A bit more code to ensure the salary worksheet contains valid numbers, does not have duplicate names and has a name for each entry in the grid on the main worksheet. Read notes in the code.

Code:
Sub SalaryValidation()
    'Ensure the names on the Main and Salary worksheets have no leading or
    '  trailing spaces.
    'Ensures each of the names on the main sheet have a single entry on the salary
    '  worksheet and displays the names and the salary range (min to max) on that worksheet.
    'This is needed because there is no way to know that a salary is incorrect
    '  (or missing) from the group totals generated on the main worksheet.  This won't help
    '  if someone enters 44,000 instead of 45,000 but will help if the entry is blank or
    '  way out of line (44 instead of 44,000)
    'It would be worthwhile to put a data validation on column B of the Salary worksheet
    '  that restricted entries to postive numbers within a reasonable salary range.
    
    Dim wksMain As Worksheet
    Set wksMain = Sheets(1)                 'wksMain holds the input grid and output list
    Dim wksSalary As Worksheet
    Set wksSalary = Worksheets("Salary")    'wksSalary holds the 2-Column Salary data
                                            '  (w/Headers: A=Name, B=Salary)
    Dim lLastRow As Long
    Dim lDupe As Long
    Dim sOutput As String
    Dim varMin As Variant
    Dim varMax As Variant
    Dim varSalary As Variant
    
    Dim oSD As Object
    Set oSD = CreateObject("Scripting.Dictionary")
    oSD.CompareMode = vbTextCompare
    
    Dim rngCell As Range
    Dim varK As Variant, varI As Variant, varTemp As Variant, lIndex As Long
    
    'Remove Error worksheets from past runs
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("Duplicate Names").Delete
    Worksheets("Missing Names").Delete
    Worksheets("Bad Salary").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    'Remove leading/trailing spaces from Names
    With wksMain
        .AutoFilterMode = False
        For Each rngCell In .Range("A1").CurrentRegion.Cells
            rngCell.Value = Trim(rngCell.Value)
        Next
    End With
    With wksSalary
        .AutoFilterMode = False
        lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        For Each rngCell In .Range("A2:A" & lLastRow).Cells
            rngCell.Value = Trim(rngCell.Value)
        Next
    End With
    
    'Check for duplicate names on wksSalary
    '  Inventory non-blank cells in column A on wksSalary
    With wksSalary
        For Each rngCell In .Range("A2:A" & lLastRow).Cells
            If Len(rngCell.Value) > 0 Then
                oSD.Item(rngCell.Value) = oSD.Item(rngCell.Value) + 1
            End If
        Next
    End With
    '  Write Names with multiple entries to manipulable array
    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
            If varI(lIndex - 1) > 1 Then
                lDupe = lDupe + 1
                varTemp(1, lDupe) = varK(lIndex - 1): varTemp(2, lDupe) = varI(lIndex - 1)
            End If
        Next
        If lDupe > 0 Then
            'Write to Error Worksheet
            AddAndNameSheet ("Duplicate Names")
            Worksheets("Duplicate Names").Range("A1").Resize(oSD.Count, 2).Value = Application.Transpose(varTemp)
            
            MsgBox "There are duplicate names on the " & wksSalary.Name & " worksheet." & vbLf & vbLf & _
                "Correct this problem and rerun the code to validate the correction."
            GoTo End_Sub
        Else
            sOutput = "No Duplicate Names on the " & wksSalary.Name & " worksheet." & vbLf
        End If
    End If
    
    'Verify each name on wksMain has corresponding name on wksSalary
    '  Inventory Names on wksMain
    Set oSD = CreateObject("Scripting.Dictionary")
    oSD.CompareMode = vbTextCompare
    
    For Each rngCell In wksMain.Range("A1").CurrentRegion.Offset(1, 0).Cells
        If Len(rngCell.Value) > 0 Then
            oSD.Item(rngCell.Value) = oSD.Item(rngCell.Value) + 1
        End If
    Next
    '  Remove names that are on wksSalary
    With wksSalary
        For Each rngCell In .Range("A2:A" & lLastRow).Cells
            If oSD.exists(rngCell.Value) Then
                oSD.Remove rngCell.Value
            End If
        Next
    End With
    '  Write to manipulable array
    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 error Worksheet
        AddAndNameSheet ("Missing Names")
        Worksheets("Missing Names").Range("A1").Resize(oSD.Count, 2).Value = Application.Transpose(varTemp)
        MsgBox "The names listed on 'Missing Names' worksheet are in the grid on" & _
            "the " & wksMain.Name & " worksheet but" & _
            "do not have an entry on the " & wksSalary.Name & " worksheet. " & vbLf & vbLf & _
            "Correct this problem and rerun the code to validate the correction."
        GoTo End_Sub
    Else
            sOutput = sOutput & _
            "No Missing Names on the " & wksSalary.Name & " worksheet." & vbLf
    End If
    
    'Verify each entry on wksSalary column A has a non-zero numeric entry in column B
    '  Inventory entries on column A that do not have a positive entry in column B
    Set oSD = CreateObject("Scripting.Dictionary")
    oSD.CompareMode = vbTextCompare
    
    varMin = 1000000
    With wksSalary
        For Each rngCell In .Range("A2:A" & lLastRow).Cells
            If Len(rngCell.Value) > 0 Then
                varSalary = rngCell.Offset(0, 1).Value
                If IsNumeric(varSalary) And varSalary > 0 Then
                    If varSalary > varMax Then varMax = varSalary
                    If varSalary < varMin Then varMin = varSalary
                Else
                    oSD.Item(rngCell.Value) = varSalary
                End If
            End If
        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 error Worksheet
        AddAndNameSheet ("Bad Salary")
        Worksheets("Bad Salary").Range("A1").Resize(oSD.Count, 2).Value = Application.Transpose(varTemp)
        MsgBox "The names listed on 'Bad Salary' worksheet do not have a positive entry on the " & _
            wksSalary.Name & " worksheet. " & vbLf & vbLf & _
            "Correct this problem and rerun the code to validate the correction."
        GoTo End_Sub
    Else
            sOutput = sOutput & _
            "All Names on the " & wksSalary.Name & " worksheet have entries ranging " & vbLf & _
                "     from " & varMin & " to " & varMax & "."
    End If
    
    
    MsgBox sOutput
    
End_Sub:
    
End Sub


Sub AddAndNameSheet(sWorksheet As String)
    'Delete worksheet sWorksheet if it exists, create new worksheet with same name after last sheet
    '  No worksheet name validity check done on sName
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets(sWorksheet).Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = sWorksheet 'After last
End Sub
 

Forum statistics

Threads
1,082,629
Messages
5,366,645
Members
400,908
Latest member
currong

Some videos you may like

This Week's Hot Topics

Top