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,

Would you be kind enough to help me again
Active sheet contains two fields (ranges) of numeric data
Each row in each field is 21 numbers (ex. A7:U7 first field, X7:AR7 second field)
Field1 A7:U68
Field2 X7:AR51
Some cells of each field colored (two different colors)
Macro should analyze both fields and copy all row (without deleting the original) with the most colored cells lets say
for field1 to row A4:U4
field2 to row X4:AR4

Thank you in advance

Boris

 

[bb86993]

Hi Sergio,

Would you be kind enough to help me again
Active sheet contains two fields (ranges) of numeric data
Each row in each field is 21 numbers (ex. A7:U7 first field, X7:AR7 second field)
Field1 A7:U68
Field2 X7:AR51
Some cells of each field colored (two different colors)
Macro should analyze both fields and copy all row (without deleting the original) with the most colored cells lets say
for field1 to row A4:U4
field2 to row X4:AR4

Thank you in advance

Boris

 

[bb86993]

Hi Sergio,

Would you be kind enough to help me again
Active sheet contains two fields (ranges) of numeric data
Each row in each field is 21 numbers (ex. A7:U7 first field, X7:AR7 second field)
Field1 A7:U68
Field2 X7:AR51
Some cells of each field colored (two different colors)
Macro should analyze both fields and copy all row (without deleting the original) with the most colored cells lets say
for field1 to row A4:U4
field2 to row X4:AR4

Thank you in advance

Boris

 

[sergioMabres]

I will help you but I do not understand what the macro should do.
I see four fields (ranges) A7:U7, X7:AR7, A7:U68, X7:AR51
I don't understand what to look and where to look
Then copy A7:U7 to A4:U4 or X7:AR7 to X4:AR4
I would need more explanning
Cheers
Sergio

 

[bb86993]

Hi Sergio,

For some reason I can see only first page of the thread and can't see the second one.
Sorry for not making myself clear enough.
Lets try it again.
Active sheet contains two "tables" (lets say that sheet divided by two)
1st "table" (first half of the sheet):
First row of the first table - A7:U7
Last row of the first table - A68:U68
So, 1st "table" - 62 rows & 21 columns

2nd "table" (second half of the sheet):
First row of the second table - X7:AR7
Last row of the second table - X51:AR51
So, 2nd "table" - 45 rows & 21 columns
Some cells of the "tables" are colored (two colors) and some not
Macro to do:
1. Check rows of the first table and find maximum colored cells
2. Color next sell after the last one (22 nd) of a chosen row
3. Copy chosen row to another location (a few rows under the last row) without deleting the original

Same procedure for the second "table"

Thank you in advance

B.

 

[sergioMabres]

Ok got it
How colored?
Text colored, background colored?
Sergio

 

[bb86993]

They colored after I ran your first macro and another one that I modified from yours.
I think "background colored"

B.

 

[sergioMabres]

Hi Boris, here is the macro I have a doubt what to do with tights counts (equal count as the max row) well I have done nothing only the first row with the max count is selected.
You can test the macro in this workbook https://dl.dropboxusercontent.com/u/23094164/Boris2.xlsm
Here is the code

Sub countColour()
    Dim t1, r1, lr1, c1, maxrow As Range
    Dim max, m1, m2, i As Integer
    
    ' 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
        For Each r1 In t1.Rows
            m1 = 0
            ' Loop thru cells of row
            For Each c1 In r1.Cells
                ' Counts cells with colour not white
                If (c1.Cells.Interior.ColorIndex <> -4142) Then
                    m1 = m1 + 1
                End If
            Next c1
            ' Records row count against max count
            If m1 > max Then
                max = m1
                Set maxrow = r1
            End If
        Set lr1 = r1
        Next r1
        ' Changes colour of max row one cell to the right, copy row bottom
        Range(maxrow.Cells(1, 21).Address).Offset(0, 1).Interior.ColorIndex = 3
        maxrow.Copy
        Range(lr1.Address).Offset(3, 0).PasteSpecial (xlPasteValues)
        
        ' Table 2 on t1 for the second loop
        Set t1 = Range("X7:AR51")
    Next i
End Sub

Tell me if you need additional help
Cheers
Sergio

 

[bb86993]

Hi Sergio,

Just a few modifications as usual
I forgot to mention equal counts.
Your first macro coloring duplicates in "green" then I run another macro (checks against different string of numbers and coloring duplicates "yellow")
I need to modify the second one though.
If it finds already colored cell - put a "red" border around it
Code:
Sub HighlightActive()
Dim cs, ca As Range

For Each cs In Selection
For Each ca In ActiveSheet.UsedRange
If ca.Value = cs.Value Then
ca.Cells.Interior.ColorIndex = 6
End If
Next ca
Next cs
End Sub

Last macro:
1. Should check colored and "bordered" cells as a separate instances of repeats (i.e. cell with #112 colored & bordered it's a double duplicate from a different strings = 2 counts)

2. MaxRow from the second table for some reason stays "selected" and copied with a border
3. All MaxCount rows should be copied as they are (colored & bordered if any)

Thank you in advance

B.

 

[sergioMabres]

Hi Boris,
I have tried my best to fulfill your requests, you can test the macros, there are a 4 of them, in this file
https://dl.dropboxusercontent.com/u/23094164/Boris2.xlsm

You shoud
1. select range and run colouring macro 1
2. select second range and run colouring macro 2
3. run count colours macro

If you want to do it again
1. run clear colours macro
2. press F9 to recalculate random data
3. do steps 1, 2 and 3 as indicated abobe

Here is the code I had to use subroutines to avoid re writing code

' Coloring in green uses selected range and Table 1 and Table 2
Sub highlightActive1()
    Dim cs, ca As Range
    ' reset colour
    Call cleansBorCol
    For Each cs In Selection
        For Each ca In ActiveSheet.UsedRange
            If ca.Value = cs.Value Then
                ca.Cells.Interior.ColorIndex = 4
            End If
        Next ca
    Next cs
End Sub

' 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)
                Else
                    ca.Cells.Interior.ColorIndex = 6
                End If
            End If
        Next ca
    Next cs
End Sub

' Counts coloured cells and copies max rows at the buttom
Sub countColour()
    Dim t1, r1, lr1, c1, tot1 As Range
    Dim max, m1, m2, i, j As Integer
    ' 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
    Range("A1").Select
End Sub

' Cleans counts colour index and  borders
Sub cleansBorCol()
    Range("V7:V68").Cells.ClearContents
    Range("AS7:AS51").Cells.ClearContents
    With ActiveSheet.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
End Sub

' 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

I hope this is what you need
Cheers
Sergio