Question

I am attempting to sort data imported via an excel macro from a Mainframe system, in order to search for potential patterns, especially for duplicates and the like. Suffice to say, the macro works fine and just serves as background to the question.

I checked for question duplicates and have not found an exact match to the language+ subject focus/specifics as yet. This stackoverflow question appeared to bear a resemblance, but I do not feel it is the same: Need to find a way to loop this macro through every other column

I have examined the AND conditional, but to be honest I feel stumped as to how to use it to help me loop through, run the comparisons and find all possible permutations of Decimal type value-based pairs.

I am sorting data based on three conditionals, with two serving as preconditions to the third, such that:

[pseudocode/thought process]
----------
IF String Comparison 1 (Cell Col 1 R 1) == (Cell Col 1 R 2) AND
IF String Comparison 2 (Cell Col 2 R 1) == (Cell Col 2 R 2) AND
IF Value of DECIMAL (Cell Col 3 R1) == DECIMAL (Cell Col 3 R2)
CHANGE CELLCOLOR to 'SomeColor'
----------
LOOP Through and run all value pair checks given String Compare 1,2 == TRUE for all 
comparisons of String Comparison 1 & String Comparison 2

I feel certain that there is a simple OOP-focused solution that just recursively loops through the cells, but I do not see it.

What follows is my example foobar data (post worksheet migration):

Category1ID Category2ID Values

CCC400 219S2 400

CCC400 219S2 400

BBB300 87F34 300

BBB300 87F34 300

ABA250 987M9 500

600DDD 0432QV 700

500ABA 01W29 600

200AAA 867B2 200

100AAA 5756A 100

100AAA 5756A 100

100AAA 5756A 100

100AAA 5756A 100

100AAA 5756A 100

Here is my current solution set —

First, I sort the data into the three columns I will use for the loop. The data is sorted by column 1 A-Z, column 2 A-Z and then column 3 smallest values to largest:

Code Block 1

Sub DataCopy()
'
' DataCopy Macro
' Move some data and sort.
'

'
    Range("B:B,D:D,F:F").Select
    Range("F1").Activate
    Selection.Copy
    Sheets("Worksheet2").Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("Worksheet2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Worksheet2").Sort.SortFields.Add Key:=Range( _
        "A2:A14"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Worksheet2").Sort.SortFields.Add Key:=Range( _
        "B2:B14"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Worksheet2").Sort.SortFields.Add Key:=Range( _
        "C2:C14"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Worksheet2").Sort
        .SetRange Range("A1:C14")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

I then attempt to loop through and “tag” the matching values based on the conditionals:

Code Block 2

Private Sub CommandButton1_Click()


'Trying to set variable in type RANGE and set variable alias rng.
Dim c As Range, rng

'Trying to set variable in type RANGE and set variable alias rng2.
Dim c2 As Range, rng2

'Trying to set variable in type RANGE and set variable alias rng3.
Dim c3 As Range, rng3

Dim LASTROW As Long

LASTROW = Cells(Rows.Count, 1).End(xlUp).Row

Set rng = Range("A2:A" & LASTROW)

Set rng2 = Range("B2:B" & LASTROW)

Set rng3 = Range("C2:C" & LASTROW)

    For Each c In rng

            'If category1ID cell Ax = Ax+1, Then go to next if
            If StrComp(c, c.Offset(1, 0)) = 0 Then

                'If category2ID cell Bx = Bx+1, Then go to next if
                If StrComp(c2, c2.Offset(1, 0)) = 0 Then

                    'If the value contained of cell Cx = C, Then highlight the value cell
                    If Round(c3, 2) = Round(c3.Offset(1, 0), 2) Then

                    c3.Interior.ColorIndex = 4

                    End If

                End If

            End If

    Next c

End Sub

Unfortunately, Code Block 2 results in the error “Run-time error ’91’: Object variable or With block variable not set.”

The errors on line 29:

If StrComp(c2, c2.Offset(1, 0)) = 0 Then

I have attempted to resolve this error a number of ways, but I have only served to increase the number of errors I trip.

In theory, if the color tagging process functioned, I would attempt to execute this block of code, perhaps in the same execution button. This code is very similar to Code Block 1, except that it simply sorts by colored cells in the value column (column 3) and then by the criteria of column 1 A-Z, column 2 A-Z and column 3 smallest to largest values:

Code Block 3

Sub ColorSort()
'
' ColorSort Macro
' Sorts by Color and then by various data criteria.
'

'
    Columns("A:C").Select
    ActiveWorkbook.Worksheets("Worksheet3").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Worksheet3").Sort.SortFields.Add(Range("C2:C14"), _
        xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(0, 255 _
        , 0)
    ActiveWorkbook.Worksheets("Worksheet3").Sort.SortFields.Add Key:=Range( _
        "A2:A14"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Worksheet3").Sort.SortFields.Add Key:=Range( _
        "B2:B14"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("Worksheet3").Sort.SortFields.Add Key:=Range( _
        "C2:C14"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Worksheet3").Sort
        .SetRange Range("A1:C14")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Code Block 3 is never executed, however, due to the Run-Time 91 error.

I am hopeful for an elegant recursive/iterative method or set of methods to fix the error and optimize performance, but any fix will do, if possible/feasible.

Much Thanks,

JackOrangeLantern

Answer 1

This should work if I understand your logic correctly:

Private Sub CommandButton1_Click()
    Dim c As Range, rng As Range
    Dim c2 As Range
    Dim c3 As Range
    Dim LASTROW As Long


    With ActiveSheet       
        LASTROW = .Cells(Rows.Count, 1).End(xlUp).Row
        Set rng = .Range("A2:A" & LASTROW)
    End With

    For Each c In rng.Cells

        Set c2 = c.Offset(0, 1)
        Set c3 = c.Offset(0, 2)

        If StrComp(c.Value, c.Offset(1, 0).Value) = 0 Then
            If StrComp(c2.Value, c2.Offset(1, 0).Value) = 0 Then
                If Round(c3.Value, 2) = Round(c3.Offset(1, 0).Value, 2) Then
                    'EDIT: highlight the original and the duplicate
                    c3.Resize(2,1).Interior.ColorIndex = 4
                End If
            End If
        End If
    Next c
End Sub

EDIT: this should be better (also works on unsorted data)

Private Sub HighlightDups()

    Const CLR_HILITE As Integer = 4
    Dim rw As Range, rng As Range
    Dim LASTROW As Long, r As Long
    Dim dict As Object, tmp

    With ActiveSheet
        LASTROW = .Cells(Rows.Count, 1).End(xlUp).Row
        Set rng = .Range("A2:C" & LASTROW)
    End With

    Set dict = CreateObject("scripting.dictionary")

    For Each rw In rng.Rows

        tmp = rw.Cells(1).Value & "~~" & rw.Cells(2).Value & _
               "~~" & CStr(Round(rw.Cells(3).Value, 1))

        If Not dict.exists(tmp) Then
            dict.Add tmp, rw.Cells(3)
        Else
            If Not dict(tmp) Is Nothing Then
                dict(tmp).Interior.ColorIndex = CLR_HILITE
                Set dict(tmp) = Nothing
            End If
            rw.Cells(3).Interior.ColorIndex = CLR_HILITE
        End If
    Next rw
End Sub