Highlighting duplicates in rows

dgray21781 · Jun 3, 2019

Hello,

I have a spreadsheet with 15 columns and over 700 rows. I would like to highlight duplicate values within each of the rows. There may be more than one duplicate. I have copied some of the data below.

For example Southampton and St Peter Port may be duplicated on the same row. I would like them to be in separate colours and using VBA not condition formatting.

01-Jun-19

Sat

St Petersburg

Southampton

Santorini

Oslo

02-Jun-19

Sun

St Petersburg

Barcelona

St Peter Port

Piraeus

Southampton

Tracy Arm/Juneau

Kristiansand

03-Jun-19

Mon

Helsinki

Stavanger

Souda Bay

Ponta Delgada

Skagway

04-Jun-19

Tue

Stockholm

Genoa

Flaam

Zeebrugge

Katakolon

Praia da Vitoria

Hubbard Glacier

Southampton

05-Jun-19

Wed

Civitavecchia

Alesund

Rotterdam

Gibraltar

Icy Strait Point

06-Jun-19

Thu

Warnemunde

Sorrento

Bergen

Rotterdam

Valletta

Cartagena (ES)

Sitka

Greenock

07-Jun-19

Fri

Madeira

Ketchikan

New York

Oban

08-Jun-19

Sat

Mallorca

Southampton

Kotor

La Palma

Marseilles

Isle of Skye (SC)

09-Jun-19

Sun

Southampton

Split

Gran Canaria

Monte Carlo

Victoria

Kirkwall

10-Jun-19

Mon

Gibraltar

Stavanger

Venice

Lanzarote

Ajaccio

Vancouver

11-Jun-19

Tue

Haugesund

Lisbon

Warnemunde

Flaam

Zadar

Barcelona

Dublin

12-Jun-19

Wed

Skjolden

Olden

Lisbon

Ketchikan

Liverpool

13-Jun-19

Thu

Alesund

Helsinki

Bergen

Valletta

Cadiz

Tracy Arm/Juneau

Cobh

14-Jun-19

Fri

Trondheim

Southampton

St Petersburg

Messina Strait

Skagway

Southampton

15-Jun-19

Sat

Hellesylt

St Petersburg

Southampton

Naples

Southampton

Icy Strait Point

St Peter Port

16-Jun-19

Sun

Geiranger

Santander

Tallinn

Civitavecchia

Southampton

Hubbard Glacier

Hamburg

Southampton

17-Jun-19

Mon

Olden

Gijon

Stockholm

Ajaccio

Killybegs

Sitka

18-Jun-19

Tue

Bergen

La Coruna

Cadiz

Olbia

Greenock

Stavanger

Zeebrugge

Haugesund

19-Jun-19

Wed

Copenhagen

Alesund

Victoria

St Peter Port

Olden

20-Jun-19

Thu

St Peter Port

Barcelona

Valletta

Torshavn

Olden

Vancouver

Flaam

21-Jun-19

Fri

Southampton

Lerwick

Bergen

Hamburg

Bergen

22-Jun-19

Sat

Southampton

Monte Carlo

Kirkwall

Ketchikan

23-Jun-19

Sun

St Peter Port

Livorno

Southampton

Tracy Arm/Juneau

Southampton

Thanks in advance.

DanteAmor · Jun 3, 2019

Re: Help with highlighting duplicates in rows

Try this

Code:

Sub highlighting_duplicates()
    Dim i As Long, c As Range, n As Long, lr As Long, lc As Long
    Dim r As Range, f As Range, cell As String
    
    lr = Range("A" & Rows.Count).End(xlUp).Row
    Range(Cells(2, 3), Cells(lr, Columns.Count)).Interior.ColorIndex = xlNone
    For i = 2 To lr
        lc = Cells(i, Columns.Count).End(xlToLeft).Column
        n = 4
        Set r = Range(Cells(i, 3), Cells(i, lc))
        For Each c In r
            If c <> "" And c.Interior.ColorIndex = xlNone And WorksheetFunction.CountIf(r, c.Value) > 1 Then
                Set f = r.Find(c.Value, LookIn:=xlValues, lookat:=xlWhole)
                cell = f.Address
                Do
                    f.Interior.ColorIndex = n
                    Set f = r.FindNext(f)
                Loop While Not f Is Nothing And f.Address <> cell
                n = n + 1
            End If
        Next
    Next
End Sub

dgray21781 · Jun 3, 2019

Re: Help with highlighting duplicates in rows

Hi,

I have a slight issue in that many of the cells are already coloured and when running the code it removes all the colour from the cells.

Is it also possible for the code to cycle through colours like in the code below which is for duplicates in a column.

Code:

Sub Find_Duplicate_Entry()


Dim cel As Variant
Dim myrng As Range
Dim clr As Long
Set myrng = Range("C3:C" & Range("C65536").End(xlUp).Row)
    myrng.Interior.ColorIndex = xlNone
    clr = 3
For Each cel In myrng
    If Application.WorksheetFunction.CountIf(myrng, cel) > 1 Then
    If WorksheetFunction.CountIf(Range("C3:C" & cel.Row), cel) = 1 Then
    cel.Interior.ColorIndex = clr
    clr = clr + 1
Else
    cel.Interior.ColorIndex = myrng.Cells(WorksheetFunction.Match(cel.Value, myrng, False), 1).Interior.ColorIndex
End If
End If
Next
End Sub

DanteAmor · Jun 3, 2019

Re: Help with highlighting duplicates in rows

dgray21781 said:
Hi,

I have a slight issue in that many of the cells are already coloured and when running the code it removes all the colour from the cells.

Is it also possible for the code to cycle through colours like in the code below which is for duplicates in a column.

Code:

Try this and tell me.

Sub highlighting_duplicates()
    Dim i As Long, c As Range, n As Long, lr As Long, lc As Long
    Dim r As Range, f As Range, cell As String
    
    lr = Range("A" & Rows.Count).End(xlUp).Row
    'Range(Cells(2, 3), Cells(lr, Columns.Count)).Interior.ColorIndex = xlNone
    For i = 2 To lr
        lc = Cells(i, Columns.Count).End(xlToLeft).Column
        n = 4
        Set r = Range(Cells(i, 3), Cells(i, lc))
        For Each c In r
            If c <> "" And WorksheetFunction.CountIf(r, c.Value) > 1 Then
                Set f = r.Find(c.Value, LookIn:=xlValues, lookat:=xlWhole)
                cell = f.Address
                Do
                    f.Interior.ColorIndex = n
                    Set f = r.FindNext(f)
                Loop While Not f Is Nothing And f.Address <> cell
                n = n + 1
            End If
        Next
    Next
End Sub

dgray21781 · Jun 3, 2019

Re: Help with highlighting duplicates in rows

You sir, are a genius.

Works like a charm, thanks.

dgray21781 · Jun 3, 2019

Re: Help with highlighting duplicates in rows

This is the full code that I am running in the sheet. Is there a way to make it more streamline?

Code:

'Format the Official Ship Schedule to enable port clashes with other CUK ships.
'
'by Derek Gray




Option Explicit
Dim totalRows, totalColumns, startRow, startColumn, c, r, i As Integer
Dim cellValue As Double
Dim cellValue2 As String


Sub SortItAaaattt()


' Remove the By Date sheet to a separate workbook
    Sheets("By Date").Select
    Sheets("By Date").Move
    Range("A2710").Select


' Remove auto filter, adjust column size and change the window zoom
    Range("A1").Select
    Selection.AutoFilter
    Columns("B:S").Select
    Selection.ColumnWidth = 18
    ActiveWindow.Zoom = 90


' Switch off screen flicker and updating temporarily to allow the macro to run quicker.
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False


' Remove rows 2 until 2558. Removing all data prior to June 2019. Also removing retired ship.
    Rows("2:2709").Select
    Selection.Delete Shift:=xlUp
    Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
    Columns("C:C").Select
    Selection.Delete Shift:=xlToLeft


' Select column A, change the date format to d-mmm-yy, choose borders and adjust size
    Columns("A:A").Select
    Selection.NumberFormat = "d-mmm-yy"
    Selection.ColumnWidth = 13
        
' Add column B, Change it to contain the day of the week and adjust column size
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.ColumnWidth = 5.43
    
' Add borders to all cells
    Range("A1:M720").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.249946592608417
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.249946592608417
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.249946592608417
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.249946592608417
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.249946592608417
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.249946592608417
        .Weight = xlThin
    End With
    
' Change turnaround port formatting
    Range("C3:M720").Select
    Application.FindFormat.Clear
    With Application.FindFormat.Font
        .FontStyle = "Bold"
        .Subscript = False
        .TintAndShade = 0
    End With
    Application.ReplaceFormat.Clear
    With Application.ReplaceFormat.Font
        .FontStyle = "Bold"
        .Subscript = False
        .Color = 192
        .TintAndShade = 0
    End With
    With Application.ReplaceFormat.Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
    Selection.Replace What:="", Replacement:="", lookat:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True
    With Application.ReplaceFormat.Font
        .FontStyle = "Bold"
        .Subscript = False
        .Color = 192
        .TintAndShade = 0
    End With
    With Application.ReplaceFormat.Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
    Cells.Replace What:="Southampton", Replacement:="Southampton", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=True
    Columns("M:M").Select
    With Application.ReplaceFormat.Font
        .FontStyle = "Bold"
        .Subscript = False
        .Color = 192
        .TintAndShade = 0
    End With
    With Application.ReplaceFormat.Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
    Cells.Replace What:="New York", Replacement:="New York", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=True
' Remove condition formatting
    Cells.FormatConditions.Delete


' This then highlights Fri in Green and Sat & Sun in Red
    Columns("B:B").Select
    Range("B2").Activate
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=OR(B2=""Sat"", B2=""Sun"")"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .Color = -16383844
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.799981688894314
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=B2=""Fri"""
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .Color = -16752384
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13561798
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False


' This is where all the strikethrough text magically disappears.
Range("C2:Q800").Select


With ActiveSheet
With Selection


' Stores the total number or rows the user has selected.
totalRows = Selection.Rows.Count


' Asks the user to select a more discreeet set if they have tried to
' run the program on the entire sheet.
If (totalRows >= 65536) Or (totalColumns >= 256) Then
MsgBox ("Please do not select the entire sheet for this utility.")
End If


' Stores the starting row and column and the total columns of the users
' selection.
startRow = Selection.Row
startColumn = Selection.Column
totalColumns = Selection.Columns.Count


' Loops through the selected range by column and row.
For c = startColumn To (startColumn + (totalColumns - 1))
For r = startRow To (startRow + (totalRows - 1))


' Shows the cell selections visually.
Cells(r, c).Select 'Debug


' Check to see if the cell has content and if it is numeric.
If Not IsEmpty(Cells(r, c).Value) And IsNumeric(Cells(r, c).Value) Then


' If the cell content is numeric, stores the content and then
' changes it to text in order to use string manipulation methods
' to check for and change the strikethrough the state of individual
' characters.
cellValue = Cells(r, c).Value
Cells(r, c).ClearContents
Cells(r, c).NumberFormat = "@"
Cells(r, c).Value = CStr(cellValue)


End If


' Checks if the cell contents are in Date format.
' Changed dates would be formatted as text.
If IsDate(Cells(r, c).Value) Then
' Dates can be represented in many different ways. If the date,
' could be confused as a number this conditional catches it based
' on the length of the string.
If (Len(Cells(r, c).Value) >= 8) Then


' If the cell format is strikethrough, changes the cell value to null.
If Cells(r, c).Font.Strikethrough Then


Cells(r, c).Value = Null


End If


End If


End If


' Now that numeric and date formats are taken care of, we are down to text.\
' This section loops through the cells text one character at a time and check
' if the text is formatted as strikethrough.
' If it is, it is delted, if not, it is passed over.
For i = Len(Range(Cells(r, c), Cells(r, c)).Text) To 1 Step -1


If Range(Cells(r, c), Cells(r, c)).Characters(i, 1).Font.Strikethrough Then


Range(Cells(r, c), Cells(r, c)).Characters(i, 1).Delete


End If


Next i


' Changes the cell format to Regular instead of Strikethrough so that
' the next person to type in the cell will get regular text.
With Range(Cells(r, c), Cells(r, c)).Font
.Strikethrough = False
End With


' If the cell is not empty ....
If Not IsEmpty(Cells(r, c).Value) Then


' Removes extra leading and trailing spaces.
cellValue2 = Trim(Cells(r, c).Value)
' If the cell is still not empty.
If Len(cellValue2) > 0 Then
' Changes the cell value to decimal.
' This will cause an error is the text doesn't
' look like a decimal number.
' In that case, the line gets skipped.
On Error Resume Next
Cells(r, c).Value = CDec(cellValue2)
End If
End If
Next r
Next c
End With
End With


' Adds a header row along the top of the sheet
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.RowHeight = 26.25
    With Selection.Font
        .Name = "Calibri"
        .Size = 20
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Range("A1:O1").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 5296274
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Selection.Font.Bold = True
    Range("A1:O1").Select
    ActiveCell.FormulaR1C1 = "SHIP LOCATIONS P&O / CUNARD"
    
' Changes date header to sentence case, adds day and changes the colour and borders.
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "Date"
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "Day"
    Range("B3").Select
    ActiveCell.FormulaR1C1 = "=TEXT(RC[-1],""ddd"")"
    Range("B3:B720").Select
    Selection.FillDown
    Range("A2:O2").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark2
        .TintAndShade = -0.899990844447157
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0.399975585192419
    End With
       
' Replace port names to make them shorter and fit the cells easier
    Cells.Replace What:="St Johns - Antigua", Replacement:="Antigua", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False


    Cells.Replace What:="Las Palmas de Gran Canaria", Replacement:="Gran Canaria", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False


    Cells.Replace What:="Arrecife de Lanzarote", Replacement:="Lanzarote", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False


    Cells.Replace What:="Isle of Skye Scenic Cruising", Replacement:="Isle of Skye (SC)", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
    Cells.Replace What:="Santa Cruz de Tenerife", Replacement:="Tenerife", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False


    Cells.Replace What:="Cartagena - Spain", Replacement:="Cartagena (ES)", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False


    Cells.Replace What:="Leknes Lofoten Islands", Replacement:="Lofoten Islands", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False


    Cells.Replace What:="Funchal Madeira", Replacement:="Madeira", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False


    Cells.Replace What:="Georgetown - Grand Cayman", Replacement:="Grand Cayman", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False


    Cells.Replace What:="Puerto del Rosario - Fuerteventura", Replacement:="Fuerteventura", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False


    Cells.Replace What:="Palma de Mallorca", Replacement:="Mallorca", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False


    Cells.Replace What:="Santa Cruz - Huatulco", Replacement:="Huatulco", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False


    Cells.Replace What:="Panama Canal - Full transit", Replacement:="Panama Canal", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False


    Cells.Replace What:="Panama Canal - Partial Transit", Replacement:="Panama Canal", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False


    Cells.Replace What:="International Date Line", Replacement:="Date Line", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False


    Cells.Replace What:="Port Victoria - Mahe Island", Replacement:="Port Victoria - Mahe", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False


    Cells.Replace What:="Cartagena - Colombia", Replacement:="Cartagena - (CO)", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
    Cells.Replace What:="Aburatsu (Miyazaki", Replacement:="Aburatsu", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
    Cells.Replace What:="Cephalonia - Argostoli", Replacement:="Cephalonia", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
    Cells.Replace What:="Kiriwina, Trobriand Islands", Replacement:="Kiriwina", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
    Cells.Replace What:="Okinawa (Naha)", Replacement:="Okinawa", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
    Cells.Replace What:="Miyakojima (Hirara)", Replacement:="Miyakojima", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
' Change at sea cells to blanks
    Cells.Replace What:="At Sea", Replacement:=" ", lookat:=xlPart _
        , SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
' Fill all blank cells with blue to indicate day at sea
    Range("C3:M720").Select
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=LEN(TRIM(C3))=0"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0.799981688894314
    End With
    Selection.FormatConditions(1).StopIfTrue = False


' Format refit cells
    With Application.ReplaceFormat.Font
        .FontStyle = "Bold Italic"
        .Subscript = False
        .ThemeColor = 1
        .TintAndShade = 0
    End With
    With Application.ReplaceFormat.Interior
        .PatternColorIndex = xlAutomatic
        .Color = 6299648
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Cells.Replace What:="Refit", Replacement:="Refit", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=True
    Cells.Replace What:="Dry dock", Replacement:="Dry dock", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=True
    Cells.Replace What:="Drydock", Replacement:="Drydock", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=True
              
' Centralise all cells
    Range("A3:M720").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With


Call highlighting_duplicates


' Switch everything back on
    Application.EnableEvents = True
    Application.DisplayStatusBar = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic


    Range("A3").Select


' Save the new file
    Application.DisplayAlerts = False
    ChDir "E:\AAA Work Related\OSS"
    ActiveWorkbook.SaveAs Filename:="E:\AAA Work Related\OSS\Ship Finder.xlsm", _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    Application.DisplayAlerts = True
        
' Close the remaining sheets of the OSS
    Windows("Carnival UK - Official Ship Schedule - June 2019.xlsm").Activate
    Application.DisplayAlerts = False
    ThisWorkbook.Close
    Application.DisplayAlerts = True
    
End Sub


Sub highlighting_duplicates()
    Dim i As Long, c As Range, n As Long, lr As Long, lc As Long
    Dim r As Range, f As Range, cell As String
    
    lr = Range("A" & Rows.Count).End(xlUp).Row
    'Range(Cells(2, 3), Cells(lr, Columns.Count)).Interior.ColorIndex = xlNone
    For i = 2 To lr
        lc = Cells(i, Columns.Count).End(xlToLeft).Column
        n = 4
        Set r = Range(Cells(i, 3), Cells(i, lc))
        For Each c In r
            If c <> "" And WorksheetFunction.CountIf(r, c.Value) > 1 Then
                Set f = r.Find(c.Value, LookIn:=xlValues, lookat:=xlWhole)
                cell = f.Address
                Do
                    f.Interior.ColorIndex = n
                    Set f = r.FindNext(f)
                Loop While Not f Is Nothing And f.Address <> cell
                n = n + 1
            End If
        Next
    Next
End Sub

DanteAmor · Jun 3, 2019

Re: Help with highlighting duplicates in rows

dgray21781 said:
You sir, are a genius.

Works like a charm, thanks.

I'm glad to help you. Thanks for the feedback.

DanteAmor · Jun 3, 2019

Re: Help with highlighting duplicates in rows

dgray21781 said:
This is the full code that I am running in the sheet. Is there a way to make it more streamline?

You have a very extensive macro here and review it step by step and line by line would take some time.

I give you some examples that you can consider to decrease some lines and some steps.

Code:

Option Explicit
Dim totalRows, totalColumns, startRow, startColumn, c, r, i As Integer
Dim cellValue As Double
Dim cellValue2 As String


Sub SortItAaaattt()


' Switch off screen flicker and updating temporarily to allow the macro to run quicker.
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False


' Remove the By Date sheet to a separate workbook
    Sheets("By Date").Select
    Sheets("By Date").Move
    'Range("A2710").Select


' Remove auto filter, adjust column size and change the window zoom
[COLOR=#0000ff]    Range("A1").AutoFilter[/COLOR]
[COLOR=#0000ff]    Columns("B:S").ColumnWidth = 18[/COLOR]
[COLOR=#0000ff]    ActiveWindow.Zoom = 90[/COLOR]


' Remove rows 2 until 2558. Removing all data prior to June 2019. Also removing retired ship.
[COLOR=#0000ff]    Rows("2:2709").Delete Shift:=xlUp[/COLOR]
[COLOR=#0000ff]    Columns("B:B").Delete Shift:=xlToLeft[/COLOR]
[COLOR=#0000ff]    Columns("C:C").Delete Shift:=xlToLeft[/COLOR]


' Select column A, change the date format to d-mmm-yy, choose borders and adjust size
    Columns("A:A").NumberFormat = "d-mmm-yy"
    Columns("A:A").ColumnWidth = 13
        
' Add column B, Change it to contain the day of the week and adjust column size
[COLOR=#0000ff]    Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove[/COLOR]
[COLOR=#0000ff]    Columns("B:B").ColumnWidth = 5.43[/COLOR]
    
' Add borders to all cells
    'Range("A1:M720").Select
    'Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    'Selection.Borders(xlDiagonalUp).LineStyle = xlNone
[COLOR=#0000ff]    With Range("A1:M720").Borders[/COLOR]
[COLOR=#0000ff]        .LineStyle = xlContinuous[/COLOR]
[COLOR=#0000ff]        .ThemeColor = 1[/COLOR]
[COLOR=#0000ff]        .TintAndShade = -0.249946592608417[/COLOR]
[COLOR=#0000ff]        .Weight = xlThin[/COLOR]
[COLOR=#0000ff]    End With[/COLOR]
'    With Selection.Borders(xlEdgeTop)
'        .LineStyle = xlContinuous
'        .ThemeColor = 1
'        .TintAndShade = -0.249946592608417
'        .Weight = xlThin
'    End With
'    With Selection.Borders(xlEdgeBottom)
'        .LineStyle = xlContinuous
'        .ThemeColor = 1
'        .TintAndShade = -0.249946592608417
'        .Weight = xlThin
'    End With
'    With Selection.Borders(xlEdgeRight)
'        .LineStyle = xlContinuous
'        .ThemeColor = 1
'        .TintAndShade = -0.249946592608417
'        .Weight = xlThin
'    End With
'    With Selection.Borders(xlInsideVertical)
'        .LineStyle = xlContinuous
'        .ThemeColor = 1
'        .TintAndShade = -0.249946592608417
'        .Weight = xlThin
'    End With
'    With Selection.Borders(xlInsideHorizontal)
'        .LineStyle = xlContinuous
'        .ThemeColor = 1
'        .TintAndShade = -0.249946592608417
'        .Weight = xlThin
'    End With
    
' Change turnaround port formatting
    Range("C3:M720").Select
    Application.FindFormat.Clear
    With Application.FindFormat.Font
        .FontStyle = "Bold"
        .Subscript = False
        .TintAndShade = 0
    End With
    Application.ReplaceFormat.Clear
    With Application.ReplaceFormat.Font
        .FontStyle = "Bold"
        .Subscript = False
        .Color = 192
        .TintAndShade = 0
    End With
    With Application.ReplaceFormat.Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
    Selection.Replace What:="", Replacement:="", lookat:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=True, ReplaceFormat:=True
    With Application.ReplaceFormat.Font
        .FontStyle = "Bold"
        .Subscript = False
        .Color = 192
        .TintAndShade = 0
    End With
    With Application.ReplaceFormat.Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
    Cells.Replace What:="Southampton", Replacement:="Southampton", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=True
    Columns("M:M").Select
    With Application.ReplaceFormat.Font
        .FontStyle = "Bold"
        .Subscript = False
        .Color = 192
        .TintAndShade = 0
    End With
    With Application.ReplaceFormat.Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
    Cells.Replace What:="New York", Replacement:="New York", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=True
' Remove condition formatting
    Cells.FormatConditions.Delete




' This then highlights Fri in Green and Sat & Sun in Red
    Columns("B:B").Select
    Range("B2").Activate
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=OR(B2=""Sat"", B2=""Sun"")"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .Color = -16383844
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0.799981688894314
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=B2=""Fri"""
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .Color = -16752384
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13561798
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False




' This is where all the strikethrough text magically disappears.
Range("C2:Q800").Select




With ActiveSheet
With Selection




' Stores the total number or rows the user has selected.
totalRows = Selection.Rows.Count




' Asks the user to select a more discreeet set if they have tried to
' run the program on the entire sheet.
If (totalRows >= 65536) Or (totalColumns >= 256) Then
MsgBox ("Please do not select the entire sheet for this utility.")
End If




' Stores the starting row and column and the total columns of the users
' selection.
startRow = Selection.Row
startColumn = Selection.Column
totalColumns = Selection.Columns.Count




' Loops through the selected range by column and row.
For c = startColumn To (startColumn + (totalColumns - 1))
For r = startRow To (startRow + (totalRows - 1))




' Shows the cell selections visually.
Cells(r, c).Select 'Debug




' Check to see if the cell has content and if it is numeric.
If Not IsEmpty(Cells(r, c).Value) And IsNumeric(Cells(r, c).Value) Then




' If the cell content is numeric, stores the content and then
' changes it to text in order to use string manipulation methods
' to check for and change the strikethrough the state of individual
' characters.
cellValue = Cells(r, c).Value
Cells(r, c).ClearContents
Cells(r, c).NumberFormat = "@"
Cells(r, c).Value = CStr(cellValue)




End If




' Checks if the cell contents are in Date format.
' Changed dates would be formatted as text.
If IsDate(Cells(r, c).Value) Then
' Dates can be represented in many different ways. If the date,
' could be confused as a number this conditional catches it based
' on the length of the string.
If (Len(Cells(r, c).Value) >= 8) Then




' If the cell format is strikethrough, changes the cell value to null.
If Cells(r, c).Font.Strikethrough Then




Cells(r, c).Value = Null




End If




End If




End If




' Now that numeric and date formats are taken care of, we are down to text.\
' This section loops through the cells text one character at a time and check
' if the text is formatted as strikethrough.
' If it is, it is delted, if not, it is passed over.
For i = Len(Range(Cells(r, c), Cells(r, c)).Text) To 1 Step -1




If Range(Cells(r, c), Cells(r, c)).Characters(i, 1).Font.Strikethrough Then




Range(Cells(r, c), Cells(r, c)).Characters(i, 1).Delete




End If




Next i




' Changes the cell format to Regular instead of Strikethrough so that
' the next person to type in the cell will get regular text.
With Range(Cells(r, c), Cells(r, c)).Font
.Strikethrough = False
End With




' If the cell is not empty ....
If Not IsEmpty(Cells(r, c).Value) Then




' Removes extra leading and trailing spaces.
cellValue2 = Trim(Cells(r, c).Value)
' If the cell is still not empty.
If Len(cellValue2) > 0 Then
' Changes the cell value to decimal.
' This will cause an error is the text doesn't
' look like a decimal number.
' In that case, the line gets skipped.
On Error Resume Next
Cells(r, c).Value = CDec(cellValue2)
End If
End If
Next r
Next c
End With
End With




' Adds a header row along the top of the sheet
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.RowHeight = 26.25
    With Selection.Font
        .Name = "Calibri"
        .Size = 20
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Range("A1:O1").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 5296274
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Selection.Font.Bold = True
    Range("A1:O1").Select
    ActiveCell.FormulaR1C1 = "SHIP LOCATIONS P&O / CUNARD"
    
' Changes date header to sentence case, adds day and changes the colour and borders.
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "Date"
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "Day"
    Range("B3").Select
    ActiveCell.FormulaR1C1 = "=TEXT(RC[-1],""ddd"")"
    Range("B3:B720").Select
    Selection.FillDown
    Range("A2:O2").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark2
        .TintAndShade = -0.899990844447157
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0.399975585192419
    End With
       
' Replace port names to make them shorter and fit the cells easier
    Cells.Replace What:="St Johns - Antigua", Replacement:="Antigua", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False




    Cells.Replace What:="Las Palmas de Gran Canaria", Replacement:="Gran Canaria", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False




    Cells.Replace What:="Arrecife de Lanzarote", Replacement:="Lanzarote", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False




    Cells.Replace What:="Isle of Skye Scenic Cruising", Replacement:="Isle of Skye (SC)", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
    Cells.Replace What:="Santa Cruz de Tenerife", Replacement:="Tenerife", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False




    Cells.Replace What:="Cartagena - Spain", Replacement:="Cartagena (ES)", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False




    Cells.Replace What:="Leknes Lofoten Islands", Replacement:="Lofoten Islands", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False




    Cells.Replace What:="Funchal Madeira", Replacement:="Madeira", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False




    Cells.Replace What:="Georgetown - Grand Cayman", Replacement:="Grand Cayman", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False




    Cells.Replace What:="Puerto del Rosario - Fuerteventura", Replacement:="Fuerteventura", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False




    Cells.Replace What:="Palma de Mallorca", Replacement:="Mallorca", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False




    Cells.Replace What:="Santa Cruz - Huatulco", Replacement:="Huatulco", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False




    Cells.Replace What:="Panama Canal - Full transit", Replacement:="Panama Canal", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False




    Cells.Replace What:="Panama Canal - Partial Transit", Replacement:="Panama Canal", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False




    Cells.Replace What:="International Date Line", Replacement:="Date Line", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False




    Cells.Replace What:="Port Victoria - Mahe Island", Replacement:="Port Victoria - Mahe", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False




    Cells.Replace What:="Cartagena - Colombia", Replacement:="Cartagena - (CO)", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
    Cells.Replace What:="Aburatsu (Miyazaki", Replacement:="Aburatsu", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
    Cells.Replace What:="Cephalonia - Argostoli", Replacement:="Cephalonia", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
    Cells.Replace What:="Kiriwina, Trobriand Islands", Replacement:="Kiriwina", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
    Cells.Replace What:="Okinawa (Naha)", Replacement:="Okinawa", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
    Cells.Replace What:="Miyakojima (Hirara)", Replacement:="Miyakojima", lookat _
        :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
' Change at sea cells to blanks
    Cells.Replace What:="At Sea", Replacement:=" ", lookat:=xlPart _
        , SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
' Fill all blank cells with blue to indicate day at sea
    Range("C3:M720").Select
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=LEN(TRIM(C3))=0"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0.799981688894314
    End With
    Selection.FormatConditions(1).StopIfTrue = False




' Format refit cells
    With Application.ReplaceFormat.Font
        .FontStyle = "Bold Italic"
        .Subscript = False
        .ThemeColor = 1
        .TintAndShade = 0
    End With
    With Application.ReplaceFormat.Interior
        .PatternColorIndex = xlAutomatic
        .Color = 6299648
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Cells.Replace What:="Refit", Replacement:="Refit", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=True
    Cells.Replace What:="Dry dock", Replacement:="Dry dock", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=True
    Cells.Replace What:="Drydock", Replacement:="Drydock", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=True
              
' Centralise all cells
    Range("A3:M720").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With




Call highlighting_duplicates




' Switch everything back on
    Application.EnableEvents = True
    Application.DisplayStatusBar = True
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic




    Range("A3").Select




' Save the new file
    Application.DisplayAlerts = False
    ChDir "E:\AAA Work Related\OSS"
    ActiveWorkbook.SaveAs Filename:="E:\AAA Work Related\OSS\Ship Finder.xlsm", _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    Application.DisplayAlerts = True
        
' Close the remaining sheets of the OSS
    Windows("Carnival UK - Official Ship Schedule - June 2019.xlsm").Activate
    Application.DisplayAlerts = False
    ThisWorkbook.Close
    Application.DisplayAlerts = True
    
End Sub

dgray21781 · Jun 4, 2019

Re: Help with highlighting duplicates in rows

That is great, thanks again

DanteAmor · Jun 4, 2019

Re: Help with highlighting duplicates in rows

dgray21781 said:
That is great, thanks again

You're welcome & thanks for the feedback.

Highlighting duplicates in rows

dgray21781

New Member

Excel Facts

DanteAmor

Well-known Member

dgray21781

New Member

DanteAmor

Well-known Member

dgray21781

New Member

dgray21781

New Member

DanteAmor

Well-known Member

DanteAmor

Well-known Member

dgray21781

New Member

DanteAmor

Well-known Member

Forum statistics

Share this page

Highlighting duplicates in rows

New Member

Excel Facts

Well-known Member

New Member

Well-known Member

New Member

New Member

Well-known Member

Well-known Member

New Member

Well-known Member

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock