Macro modification needed.

[nair.harish]

Hi

The below macro works perfectly, except that it does not highlight duplicate lines on a particular sheet. If there are 3 similar lines it highlights only one and moves forward. heres the link to the workbook (http://www57.zippyshare.com/view.jsp?locale=en&key=97096454), i have marked it in red the lines that did not highlight. the consolidated sheet is where the macro refers which lines to highlight.

Sub replaceColours()
Dim cl As Range
Dim CI As Long
Dim i As Integer
Dim strText As String
For Each cl In ActiveSheet.UsedRange.Columns(1).Cells
CI = cl.Interior.Color
If CI <> 16777215 Then
strText = cl.Value
For i = 1 To Worksheets.Count

' find next instance of strText
Dim rngNext As Range: Set rngNext = Worksheets(i).Cells.Find(What:=strText, After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False)

' if found, colour it
If Not rngNext Is Nothing Then rngNext.Interior.Color = CI

Next i
End If
Next cl
End Sub

 

[Saagar]

Nair - .Find method only finds one occurrence. I added a loop to find all occurrences. Here is the modified code. Let me know if it works. Good luck!

Sub replaceColours()
Dim cl As Range
Dim CI As Long
Dim i As Integer
Dim strText As String
Dim rngNext As Range

With Application
    CurrentScreenUpdating = .ScreenUpdating
    CurrentCalculate = .Calculation
    CurrentEnableEvents = .EnableEvents
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
End With

Sheets("Consolidated").Activate

For Each cl In ActiveSheet.UsedRange.Columns(1).Cells
    CI = cl.Interior.Color
    cl.Select
    If CI <> 16777215 Then
        strText = cl.Value
        For i = 1 To Worksheets.Count
            oldAddress = ""
            flag = True
            Do Until flag = False
            ' find next instance of strText
            Set rngNext = Worksheets(i).Cells.Find(What:=strText, After:=ActiveCell, LookIn:= _
                xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
                xlNext, MatchCase:=False, SearchFormat:=False)
            
            ' if found, colour it
            If Not rngNext Is Nothing Then
                Worksheets(i).Activate
                rngNext.Interior.Color = CI
                rngNext.Select
                If rngNext.Address <= oldAddress Then
                    flag = False
                End If
                oldAddress = rngNext.Address
            Else
                flag = False
            End If
            Loop
        Next i
    End If
    Sheets("Consolidated").Activate
Next cl

With Application
    .ScreenUpdating = CurrentScreenUpdating
    .Calculation = CurrentCalculate
    .EnableEvents = CurrentEnableEvents
End With
End Sub

 

[nair.harish]

Thanx for the help.... it works... well while i ran the code on a particular sheet it highlighted only three lines and it did not highlight the fourth line... so i tried copying a few more lines below it and but it still did not highlight more than three lines for that sheet, so i copied and pasted that line on another sheet and it worked fine... i dont know if i ran the code wrongly... Kindly recheck the code... I feel something must have gone wrong at my end...

Thank You

 

[Saagar]

I rechecked the code... looks good to me. However, I made a small change. Test this:

Sub replaceColours()
Dim cl As Range
Dim CI As Long
Dim i As Integer
Dim strText As String
Dim rngNext As Range

With Application
    CurrentScreenUpdating = .ScreenUpdating
    CurrentCalculate = .Calculation
    CurrentEnableEvents = .EnableEvents
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
End With

Sheets("Consolidated").Activate

For Each cl In ActiveSheet.UsedRange.Columns(1).Cells
    CI = cl.Interior.Color
    cl.Select
    If CI <> 16777215 Then
        strText = cl.Value
        For i = 1 To Worksheets.Count
            oldAddress = 0
            flag = True
            Do Until flag = False
            ' find next instance of strText
            Set rngNext = Worksheets(i).Cells.Find(What:=strText, After:=ActiveCell, LookIn:= _
                xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
                xlNext, MatchCase:=False, SearchFormat:=False)
            
            ' if found, colour it
            If Not rngNext Is Nothing Then
                Worksheets(i).Activate
                rngNext.Interior.Color = CI
                rngNext.Select
                If rngNext.Row <= oldAddress Then
                    flag = False
                End If
                oldAddress = rngNext.Row
            Else
                flag = False
            End If
            Loop
        Next i
    End If
    Sheets("Consolidated").Activate
Next cl

With Application
    .ScreenUpdating = CurrentScreenUpdating
    .Calculation = CurrentCalculate
    .EnableEvents = CurrentEnableEvents
End With
End Sub

 

[nair.harish]

Eureka it worked.... not a single glitch... thanx for all your help....

 

[Saagar]

Great - you are welcome Nair.