Finding Numerical Value Pairs With Conditionals and Nested If-Then Statements - VBA Excel 2007

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

Block2: you never set C2 or c3 to anything... Also, to help you get your issues resolved more effectively here, you should always indicate which line an error occurs on, and include the error message, not just the number. — Tim Williams, Jul 23 '12 at 21:01
Then, I assume that Dim c2 As Range, rng2 then referencing rng2 bears no relevance to c2? How do I loop through the second range, then? Do I just set c2 and c3 as ranges and then run them through the loop? — Scott Conover, Jul 23 '12 at 21:04
Tim, I have bolded and italicized where I initially noted the error message in my post. The Run-time message occurs on line 29 -- "If StrComp(c2, c2.Offset(1, 0)) = 0 Then". When I assign the Range simply to c2 and c3, respectively, a type mismatch error occurs on line 32 -- "If Round(c3, 2) = Round(c3.Offset(1, 0), 2) Then." — Scott Conover, Jul 23 '12 at 21:16
Tim, The edits are solid, but there is one piece missing - I tried to fix it myself before returning :) but the recursion fails to account for odd leftovers that still match, e.g. 100AAA 5756A 100 CCC400 219S2 400. I have added tabulated data above as best as I could - my novice SO status leaves me weak with tables :) — Scott Conover, Jul 23 '12 at 21:59
See my edit. Some items will highlighted twice - a more efficient approach would be better if your tables are very large. — Tim Williams, Jul 23 '12 at 22:12
I will take a look later today (GTG), but while I am modeling using a simple dataset - both for myself and for future vba coders - I am working with 6,000 records plus from a Mainframe - a process which may be repeated in other areas for further analysis ;) Thus, efficiency is key in this case. — Scott Conover, Jul 23 '12 at 22:16

Tim Williams · Accepted Answer · 2012-07-23T23:16:28.240

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

Interesting... It by and large works, but two of the combinations are missed... I should post the data so you can see what the foobar example I made so I can see if I have any logic holes in my thinking. — Scott Conover, Jul 23 '12 at 21:27
Boom! It works very fine. The method (sub) HighlightDups did the trick. I very much like the use of associative arrays - it gave me the warm fuzzies, and it was efficiently set as temporary storage =) For data mixed in with other data columns, all that was needed was to macro-copy it to a second worksheet, process it as contiguous data, and then shuck it back out to the original worksheet. Very kewl, Tim, thanks very much for your aid. I am going to be on SO much more in the foreseeable future, so I will upvote this once I reach 15 rep. — Scott Conover, Jul 24 '12 at 14:41

Finding Numerical Value Pairs With Conditionals and Nested If-Then Statements - VBA Excel 2007

Code Block 1

Code Block 2

Code Block 3

1 Answers1

Linked