Macro to compare "main row"

[bb86993]

Hello to All
Urgent help needed
1. Workbook (two sheets with numbers)
2. User manually selects range of cells (numbers in same row but different columns)
Example (main selection):
c d e f g h i j k l
1 2 3 4 5 6 7 8 9 10

3. Macro checks both sheets, compares "Main Selection" with other rows and highlights "doubles" (including "main selection")

Example rows (could be different length):
1) 2 5 7 15 27 56 47 74 85 1 10... (2,5,7,1,10 would be highlighted)
2) 1 3 8 4 22 33 55 90 10 6 7 9... (1,3,8,4,10,6,7,9 would be highlighted)

I found macro to compare ActiveCell but don't know how to modify it accordingly. Too far from programming

Sub HighlightCells()
ActiveSheet.UsedRange.Cells.FormatConditions.Delete
ActiveSheet.UsedRange.Cells.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:=ActiveCell
ActiveSheet.UsedRange.Cells.FormatConditions(1).Interior.ColorIndex = 4

End Sub

Thank you in advance
Your help is very appreciated

 

[bb86993]

Hi Sergio,

I got lost
Lets check it again

1step (1st macro that you supplied) WORKING

User selects range in the 1st sheet
Macro checks 1 & 2 (with tables), coloring duplicates

Sub HighlightCells() Dim cs, ca As Range Dim i As Integer For i = 1 To 2 Sheets(i).UsedRange.Cells.Interior.ColorIndex = 0 For Each cs In Selection For Each ca In Sheets(i).UsedRange If ca.Value = cs.Value Then ca.Cells.Interior.ColorIndex = 4 End If Next ca Next cs Next i End Sub

2 step (2nd macro)NOT WORKING
Some cells are colored "green" after 1st macro
' Coloring in yellow, if already painted in green paints border, uses selected range and Table 1 and Table 2 Sub highlightActive2() Dim cs, ca As Range For Each cs In Selection For Each ca In ActiveSheet.UsedRange If ca.Value = cs.Value Then If (ca.Cells.Interior.ColorIndex <> -4142) Then Call paintBorInt(ca)Error "Sub or Function not defined" Else ca.Cells.Interior.ColorIndex = 6 End If End If Next ca Next cs End Sub

1. For some reason macro only checks for duplicates and coloring in yellow only 1st sheet
2. No borders for "double duplicates"

Can't completely test 3d macro "Counts colored cells and copies max rows at the bottom" because of double duplicates (bordered cells)
are not counted.

Thanks

B.
</pre>

 

[sergioMabres]

Please download and test this sheet it is working fine here
https://dl.dropboxusercontent.com/u/23094164/Boris2.xlsm
Then move to your sheet and re test
Sergio

 

[sergioMabres]

I do not want to debug when I have a working code, but the error you pointed (Error "Sub or Function not defined) is that a subroutine is not present in your code and in my code it is, so please see if in your code you have a subroutine like this

' Paints border of range yellow
Sub paintBorInt(r1 As Range)
    With r1.Cells.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Color = -16711681
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With r1.Cells.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Color = -16711681
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With r1.Cells.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Color = -16711681
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With r1.Cells.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Color = -16711681
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With r1.Cells.Borders(xlDiagonalUp)
        .LineStyle = xlContinuous
        .Color = -16711681
        .TintAndShade = 0
        .Weight = xlThin
    End With
End Sub

Or just test the code in my sheet
Sergio

 

[bb86993]

Sergio,
It's not my code. It's yours.
I just tried to modify it in order to not bother you again
As I mentioned before, It's working only with Active Sheet. Your first macro checked/compared both sheets
Sub highlightActive1() - should run through sheet #1 (were range is selected) & sheet #2 (tables)
Sub highlightActive2() - same
Sub countColour() is almost OK. It checks only sheet#2 (tables)
Sub cleansBorCol() and Sub paintBorInt(r1 As Range) - i think both sheets
Could you also change "double duplicates" cells border from yellow to red.
I really hope that it'll be the final touch

Thank you in advance
Have a good weekend

B.

 

[sergioMabres]

now to your requests:
As I mentioned before, It's working only with Active Sheet. Your first macro checked/compared both sheets
I can fix that, forgot that worked on sheets 1 and two

For i = 1 To 2     
    Sheets(i).UsedRange.Cells.Interior.ColorIndex = 0         
    For Each cs In Selection             
         For Each ca In Sheets(i).UsedRange                 
              If ca.Value = cs.Value Then                     
                    ca.Cells.Interior.ColorIndex = 4                 
              End If             
          Next ca         
      Next cs     
Next i

Sub highlightActive1() - should run through sheet #1 (were range is selected) & sheet #2 (tables)
I can fix that
Sub highlightActive2() - same
I can fix that
Sub countColour() is almost OK. It checks only sheet#2 (tables)
I am lost here, has sheet 2 also two tables 1 and 2 in the same address?
If yes no problem I can fix that
I will need you to confirm location of tables 1 and 2 in sheet 2
Sub cleansBorCol() and Sub paintBorInt(r1 As Range) - i think both sheets
I can fix that
Could you also change "double duplicates" cells border from yellow to red.
I am lost here, I do not understand, so first match is green background, second match is yellow background, but double match is green with red borders?
I will need confirmation on the colours, I find the choose of colours odd

Cheers
Sergio

 

[bb86993]

Only sheet #2 has tables. You set it up perfectly (your test sheet)
User runs Sub countColour() from sheet #2 (active)
Why do you think that choice of colors is odd?
It's hard to see yellow border/diagonal on a green colored cell if a neighbored cell or cells are also colored in yellow.
Any input is welcomed

B.

 

[sergioMabres]

I think I covered every thing, you can test the workbook here:
https://dl.dropboxusercontent.com/u/23094164/Boris2.xlsm

An here is the code, I kept the diagonal border yellow I need it to find double matchs

' Coloring in green uses selected range and Table 1 and Table 2
Sub highlightActive1()
    Dim cs, ca As Range
    Dim i As Integer
    ' reset colour
    Call cleansBorCol
    For i = 1 To 2
        For Each cs In Selection
            For Each ca In Sheets(i).UsedRange
                If ca.Value = cs.Value Then
                    ca.Cells.Interior.ColorIndex = 4
                End If
            Next ca
        Next cs
    Next i
End Sub
' Coloring in yellow, if already painted in green paints border in red, uses selected range and Table 1 and Table 2
Sub highlightActive2()
    Dim cs, ca As Range
    Dim i As Integer
    For i = 1 To 2
        For Each cs In Selection
            For Each ca In Sheets(i).UsedRange
                If ca.Value = cs.Value Then
                    If (ca.Cells.Interior.ColorIndex <> -4142) Then
                        Call paintBorInt(ca)
                    Else
                        ca.Cells.Interior.ColorIndex = 6
                    End If
                End If
            Next ca
        Next cs
    Next i
End Sub

' Counts coloured cells and copies max rows at the buttom only on page two
Sub countColour()
    Dim t1, r1, lr1, c1, tot1 As Range
    Dim max, m1, m2, i, j As Integer
    ' selects sheet two
    Sheets(2).Select
    
    ' init vars
    Set tot1 = Range("V7:V68")
        
    ' process Table 1
    Set t1 = Range("A7:U68")
    
    ' I am lazzy not going to write two times so I do a loop first table 1 then table 2
    For i = 1 To 2
        max = 0
        ' Loop thru rows in table 1 or 2
        For Each r1 In t1.Rows
            m1 = 0
            ' Loop thru cells of a row
            For Each c1 In r1.Cells
                ' Counts cells with colour not white, green or yellow
                If (c1.Cells.Interior.ColorIndex <> -4142) Then
                    m1 = m1 + 1
                End If
                ' Counts cells with border not white
                If (c1.Cells.Borders(xlDiagonalUp).Color <> 0) Then
                    m1 = m1 + 1
                End If
            Next c1
            ' Records row count against max count
            If m1 >= max Then
                max = m1
                Range(r1.Cells(1, 21).Address).Offset(0, 1).Value = m1
            End If
        Set lr1 = r1
        Next r1
        ' Changes colour of max row one cell to the right, copy row bottom
        j = 1
        For Each c1 In tot1
            ' Finds rows with max count
            If c1.Cells(1, 1).Value = max Then
                c1.Cells(1, 1).Interior.ColorIndex = 3
                Range(Cells(c1.Cells(1, 1).Row, c1.Cells(1, 1).Column - 21), Cells(c1.Cells(1, 1).Row, c1.Cells(1, 1).Column - 1)).Copy
                Range(lr1.Address).Offset(2 + j, 0).PasteSpecial xlPasteFormats
                Range(lr1.Address).Offset(2 + j, 0).PasteSpecial xlPasteValues
                j = j + 1
            Else
                c1.Cells(1, 1).ClearContents
            End If
        Next c1
        ' Table 2 on t1 for the second loop
        Set t1 = Range("X7:AR51")
        Set tot1 = Range("AS7:AS51")
    Next i
    Application.CutCopyMode = False
    Range("A1").Select
    Sheets(1).Select
    Range("A1").Select
End Sub
' Cleans counts colour index and  borders
Sub cleansBorCol()
    Dim i As Integer
    For i = 1 To 2
        Sheets(i).Range("V7:V68").Cells.ClearContents
        Sheets(i).Range("AS7:AS51").Cells.ClearContents
        With Sheets(i).UsedRange
            .Cells.Interior.ColorIndex = 0
            .Cells.Borders(xlDiagonalDown).LineStyle = xlNone
            .Cells.Borders(xlDiagonalUp).LineStyle = xlNone
            .Cells.Borders(xlEdgeLeft).LineStyle = xlNone
            .Cells.Borders(xlEdgeTop).LineStyle = xlNone
            .Cells.Borders(xlEdgeBottom).LineStyle = xlNone
            .Cells.Borders(xlEdgeRight).LineStyle = xlNone
            .Cells.Borders(xlInsideVertical).LineStyle = xlNone
            .Cells.Borders(xlInsideHorizontal).LineStyle = xlNone
        End With
    Next i
End Sub
' Paints border of range in colour
Sub paintBorInt(r1 As Range)
    With r1.Cells.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Color = -16776961
        .TintAndShade = 0
        .Weight = xlThick
    End With
    With r1.Cells.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Color = -16776961
        .TintAndShade = 0
        .Weight = xlThick
    End With
    With r1.Cells.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Color = -16776961
        .TintAndShade = 0
        .Weight = xlThick
    End With
    With r1.Cells.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Color = -16776961
        .TintAndShade = 0
        .Weight = xlThick
    End With
    With r1.Cells.Borders(xlDiagonalUp)
        .LineStyle = xlContinuous
        .Color = -16711681
        .TintAndShade = 0
        .Weight = xlHairline
    End With
End Sub

Let me know what do you think
Cheers
Sergio

 

[bb86993]

Hi Sergio,

It's working.
One more touch
Final "cleaning" macro also to clear content of the "max rows" from the bottom of sheet#2

Thank you very much for your help
All the best

B.

 

[bb86993]

Just noticed
For some reason the very first macro

Sub highlightActive1() "cleaning" data from the column "V" of my sheet #1

B.
</pre>

 

[bb86993]

Just noticed
For some reason the very first macro

Sub highlightActive1() "cleaning" data from the column "V" of my sheet #1

B.