Page 2 of 2 FirstFirst 12
Results 11 to 12 of 12

Thread: All Combinations of Multiple Columns Without Duplicates
Thanks Thanks: 0 Likes Likes: 0

  1. #11
    Board Regular pbornemeier's Avatar
    Join Date
    May 2005
    Location
    Virginia Beach, VA USA
    Posts
    3,659
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    1 Thread(s)

    Default Re: All Combinations of Multiple Columns Without Duplicates

    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
    Phil

    - Use CODE tags to keep your code formatted. See: BB Tags
    - How to attach Screenshots
    - Try searching for your answer first, see how
    - Test and validate results for all code on a copy of your worksheet!! How do you use the code you just found?
    - Posting guidelines, forum rules and terms of use
    - Read the FAQs

  2. #12
    New Member
    Join Date
    Aug 2019
    Posts
    8
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: All Combinations of Multiple Columns Without Duplicates

    Thank you again Phil. Always appreciate your help on this.

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •