Dirk Wessels macros

Sub PSPCompareList()
'
' PSPCompareList Macro

'

'

UserForm1.Show

End Sub




Dim Range1 As Range, Range2 As Range

Dim R1Col1 As Long, R2Col1 As Long, R1Col2 As Long, R2Col2 As Long
Dim R1Col3 As Long, R2Col3 As Long
Dim R1ColCount As Long, R2ColCount As Long
Dim R1ActiveRow As Long, R2ActiveRow As Long
Dim ResultsRow As Long
Dim NewSheet As Worksheet


Private Sub CommandButton1_Click()
' ListCompare macro by Dirk Wessels from www.pspsoftware.co.za
' You shouldn't be looking at this code, but I don't really mind as this is a free macro anyway
' If you do look at this, please forgive my naming convensions and coding style (like using global variables!!!)
' I am not really a VBA expert and this was a learning experience for me.
' Does the job however, so who cares

TimeStart = Now()


If Me.RefEdit1.Value = "" Or Me.RefEdit2.Value = "" Or Range1Col1.ListIndex = -1 Or Range2Col1.ListIndex = -1 Then
    MsgBox "Please select both ranges and at least 1 set of criteria columns to compare."
    Exit Sub
End If


'Create a new worksheet
Workbooks.Add
Set NewSheet = ActiveSheet
NewSheet.Name = "ListCompare Results"

'Copy the header row
R1ActiveRow = 1
R2ActiveRow = 1
ResultsRow = 1
R1ColCount = Range1.Columns.Count
R2ColCount = Range2.Columns.Count
CopyR1Row ("Match")
CopyR2Row ("Match")
ResultsRow = ResultsRow + 1

'Ignore the header row for sorting
Set Range1 = Range1.Offset(RowOffset:=1)
Set Range2 = Range2.Offset(RowOffset:=1)

'Get column index for criteria/condition columns
R1Col1 = Range1Col1.ListIndex + 1
R2Col1 = Range2Col1.ListIndex + 1
R1Col2 = Range1Col2.ListIndex + 1
R2Col2 = Range2Col2.ListIndex + 1
R1Col3 = Range1Col3.ListIndex + 1
R2Col3 = Range2Col3.ListIndex + 1



'Must sort the ranges to ensure values will ever match
If R1Col2 > 0 And R1Col3 > 0 Then
    Range1.Sort Key1:=Range1.Columns(R1Col1), Key2:=Range1.Columns(R1Col2), Key3:=Range1.Columns(R1Col3)
ElseIf R1Col2 > 0 Then
    Range1.Sort Key1:=Range1.Columns(R1Col1), Key2:=Range1.Columns(R1Col2)
ElseIf R1Col3 > 0 Then
    Range1.Sort Key1:=Range1.Columns(R1Col1), Key2:=Range1.Columns(R1Col3)
Else
    Range1.Sort Key1:=Range1.Columns(R1Col1)
End If

If R2Col2 > 0 And R2Col3 > 0 Then
    Range2.Sort Key1:=Range2.Columns(R2Col1), Key2:=Range2.Columns(R2Col2), Key3:=Range2.Columns(R2Col3)
ElseIf R2Col2 > 0 Then
    Range2.Sort Key1:=Range2.Columns(R2Col1), Key2:=Range2.Columns(R2Col2)
ElseIf R2Col3 > 0 Then
    Range2.Sort Key1:=Range2.Columns(R2Col1), Key2:=Range2.Columns(R2Col3)
Else
    Range2.Sort Key1:=Range2.Columns(R2Col1)
End If

'Loop through all rows in both ranges
'Return values 3,4 and 5 from ConditionsMet() should ensure this is not and endless loop?
While (R1ActiveRow < Range1.Rows.Count) Or (R2ActiveRow < Range2.Rows.Count)
    RowState = ConditionsMet()
    If RowState = 0 Then
        'Rows match
        CopyR1Row ("Match")
        CopyR2Row ("Match")
        R1ActiveRow = R1ActiveRow + 1
        R2ActiveRow = R2ActiveRow + 1
    ElseIf RowState = 1 Then
        'Range1's criteria is smaller, so copy range1 row and move on
        CopyR1Row ("No")
        R1ActiveRow = R1ActiveRow + 1
    ElseIf RowState = 2 Then
        'Range1's criteria is smaller, so copy range1 row and move on
        CopyR2Row ("No")
        R2ActiveRow = R2ActiveRow + 1
    ElseIf RowState = 3 Then
        'Passed end of Range1, so now we just copy Range2 row in same loop until end of Range2
        CopyR2Row ("No")
        R2ActiveRow = R2ActiveRow + 1
    ElseIf RowState = 4 Then
        'Passed end of Range2, so now we just copy Range1 row in same loop until end of Range1
        CopyR1Row ("No")
        R1ActiveRow = R1ActiveRow + 1
    'RowState = 5 will be taken care of by While condition?
    End If
    ResultsRow = ResultsRow + 1
Wend

TimeEnd = Now()

If R1ActiveRow >= R2ActiveRow Then
    MsgBox (R1ActiveRow & " Rows took " & DateDiff("s", TimeStart, TimeEnd) & " seconds")
Else
    MsgBox (R2ActiveRow & " Rows took " & DateDiff("s", TimeStart, TimeEnd) & " seconds")
End If


End Sub
Function ConditionsMet()
    Dim Cond1 As Integer, cond2 As Integer, cond3 As Integer
    'Currently checking a maximum of 2 criteria with an AND operator
    'This function can be extended though to cater for more criteria
    'and an OR operator without changing the rest above
        
    Cond1 = 0
    cond2 = 0
    cond3 = 0
    'Avoid endless loop by checking if we have passed end of one of the ranges
    If R1ActiveRow > Range1.Rows.Count And R2ActiveRow > Range2.Rows.Count Then
        ConditionsMet = 5
        Exit Function
    ElseIf R1ActiveRow > Range1.Rows.Count Then
        ConditionsMet = 3
        Exit Function
    ElseIf R2ActiveRow > Range2.Rows.Count Then
        ConditionsMet = 4
        Exit Function
    End If
    
    'Condition1
    If R1Col1 = 0 Or R2Col1 = 0 Then
        Cond1 = 0
    ElseIf Range1.Cells(R1ActiveRow, R1Col1).Value = Range2.Cells(R2ActiveRow, R2Col1).Value Then
        Cond1 = 0
    ElseIf Range1.Cells(R1ActiveRow, R1Col1).Value < Range2.Cells(R2ActiveRow, R2Col1).Value Then
        Cond1 = 1
    Else
        Cond1 = 2
    End If
    'Condition2
    If R1Col2 = 0 Or R2Col2 = 0 Then
        cond2 = 0
    ElseIf Range1.Cells(R1ActiveRow, R1Col2).Value = Range2.Cells(R2ActiveRow, R2Col2).Value Then
        cond2 = 0
    ElseIf Range1.Cells(R1ActiveRow, R1Col2).Value < Range2.Cells(R2ActiveRow, R2Col2).Value Then
        cond2 = 1
    Else
        cond2 = 2
    End If
    'Condition3
    If R1Col3 = 0 Or R2Col3 = 0 Then
        cond3 = 0
    ElseIf Range1.Cells(R1ActiveRow, R1Col3).Value = Range2.Cells(R2ActiveRow, R2Col3).Value Then
        cond3 = 0
    ElseIf Range1.Cells(R1ActiveRow, R1Col3).Value < Range2.Cells(R2ActiveRow, R2Col3).Value Then
        cond3 = 1
    Else
        cond3 = 2
    End If
    
    If Cond1 = 0 And cond2 = 0 And cond3 = 0 Then
        ConditionsMet = 0
    ElseIf Cond1 = 1 Then
        ConditionsMet = 1
    ElseIf Cond1 = 2 Then
        ConditionsMet = 2
    ElseIf cond2 = 1 Then
        ConditionsMet = 1
    ElseIf cond2 = 2 Then
        ConditionsMet = 2
    ElseIf cond3 = 1 Then
        ConditionsMet = 1
    ElseIf cond3 = 2 Then
        ConditionsMet = 2
    End If
        
End Function

Sub CopyR1Row(Matched)
'Dim bob As CellFormat

'bob.Font.Background = "#000000"

    For ColNum = 1 To R1ColCount
        NewSheet.Cells(ResultsRow, ColNum) = Range1.Cells(R1ActiveRow, ColNum)
        If Matched = "No" Then
            With NewSheet.Cells(ResultsRow, ColNum).Interior
                .ColorIndex = 6
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
            End With
        End If
    Next
    If Matched = "No" Then
        NewSheet.Cells(ResultsRow, R1ColCount + 1).Value = "No Match"
    End If
        
End Sub
Sub CopyR2Row(Matched)
    For ColNum = 1 To R2ColCount
        NewSheet.Cells(ResultsRow, ColNum + R1ColCount + 1) = Range2.Cells(R2ActiveRow, ColNum)
        If Matched = "No" Then
            With NewSheet.Cells(ResultsRow, ColNum + R1ColCount + 1).Interior
                .ColorIndex = 6
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
            End With
        End If
    Next
    If Matched = "No" Then
        NewSheet.Cells(ResultsRow, R1ColCount + 1).Value = "No Match"
    End If
End Sub


Private Sub UpdCrit_Click()
    Dim DummyRange As Range
    
    'Fill Criteria columns with column headers from ranges so that the user
    'can select which columns to use for comparing
    
    If Me.RefEdit1.Value = "" Or Me.RefEdit2.Value = "" Then
        MsgBox "Please select both ranges first"
        Exit Sub
    End If
    
    Set DummyRange = Range(Me.RefEdit1.Value)
    If R1Expand.Value = True Then
      Set Range1 = DummyRange.CurrentRegion
    Else
      Set Range1 = DummyRange
    End If
    
    Set DummyRange = Range(Me.RefEdit2.Value)
    If R2Expand.Value = True Then
      Set Range2 = DummyRange.CurrentRegion
    Else
      Set Range2 = DummyRange
    End If
    
    Range1Col1.Clear
    Range2Col1.Clear
    
    For Each col In Range1.Columns
        avalue = col.Cells(1, 1).Value
        Range1Col1.AddItem (col.Cells(1, 1).Value)
        Range1Col2.AddItem (col.Cells(1, 1).Value)
        Range1Col3.AddItem (col.Cells(1, 1).Value)
    Next
    
    For Each col In Range2.Columns
        Range2Col1.AddItem (col.Cells(1, 1).Value)
        Range2Col2.AddItem (col.Cells(1, 1).Value)
        Range2Col3.AddItem (col.Cells(1, 1).Value)
    Next
End Sub