Highlighting duplicates in rows

D

dgray21781

New Member
Joined
Aug 29, 2015
Messages
7
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.


[TABLE="width: 1437"]
<colgroup><col><col><col><col><col span="6"><col span="2"><col></colgroup><tbody>[TR]
[TD]01-Jun-19[/TD]
[TD]Sat[/TD]
[TD]St Petersburg[/TD]
[TD] [/TD]
[TD]Southampton[/TD]
[TD]Southampton[/TD]
[TD] [/TD]
[TD] Santorini[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD]Oslo[/TD]
[/TR]
[TR]
[TD]02-Jun-19[/TD]
[TD]Sun[/TD]
[TD]St Petersburg[/TD]
[TD]Barcelona[/TD]
[TD] [/TD]
[TD]St Peter Port[/TD]
[TD] [/TD]
[TD] Piraeus[/TD]
[TD] [/TD]
[TD]Southampton[/TD]
[TD]Tracy Arm/Juneau[/TD]
[TD] [/TD]
[TD]Kristiansand[/TD]
[/TR]
[TR]
[TD]03-Jun-19[/TD]
[TD]Mon[/TD]
[TD]Helsinki[/TD]
[TD] [/TD]
[TD]Stavanger[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] Souda Bay[/TD]
[TD]Ponta Delgada[/TD]
[TD] [/TD]
[TD]Skagway[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]04-Jun-19[/TD]
[TD]Tue[/TD]
[TD]Stockholm[/TD]
[TD]Genoa[/TD]
[TD]Flaam[/TD]
[TD]Zeebrugge[/TD]
[TD] [/TD]
[TD] Katakolon[/TD]
[TD]Praia da Vitoria[/TD]
[TD] [/TD]
[TD]Hubbard Glacier[/TD]
[TD] [/TD]
[TD]Southampton[/TD]
[/TR]
[TR]
[TD]05-Jun-19[/TD]
[TD]Wed[/TD]
[TD] [/TD]
[TD]Civitavecchia[/TD]
[TD]Alesund[/TD]
[TD]Rotterdam[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] Gibraltar[/TD]
[TD]Icy Strait Point[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]06-Jun-19[/TD]
[TD]Thu[/TD]
[TD]Warnemunde[/TD]
[TD]Sorrento[/TD]
[TD]Bergen[/TD]
[TD]Rotterdam[/TD]
[TD] [/TD]
[TD]Valletta[/TD]
[TD] [/TD]
[TD]Cartagena (ES)[/TD]
[TD]Sitka[/TD]
[TD] [/TD]
[TD]Greenock[/TD]
[/TR]
[TR]
[TD]07-Jun-19[/TD]
[TD]Fri[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD]Madeira[/TD]
[TD] [/TD]
[TD]Ketchikan[/TD]
[TD]New York[/TD]
[TD]Oban[/TD]
[/TR]
[TR]
[TD]08-Jun-19[/TD]
[TD]Sat[/TD]
[TD] [/TD]
[TD]Mallorca[/TD]
[TD]Southampton[/TD]
[TD]Southampton[/TD]
[TD] [/TD]
[TD] Kotor[/TD]
[TD]La Palma[/TD]
[TD]Marseilles[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]Isle of Skye (SC)[/TD]
[/TR]
[TR]
[TD]09-Jun-19[/TD]
[TD]Sun[/TD]
[TD]Southampton[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] Split[/TD]
[TD]Gran Canaria[/TD]
[TD]Monte Carlo[/TD]
[TD]Victoria[/TD]
[TD] [/TD]
[TD]Kirkwall[/TD]
[/TR]
[TR]
[TD]10-Jun-19[/TD]
[TD]Mon[/TD]
[TD] [/TD]
[TD]Gibraltar[/TD]
[TD] [/TD]
[TD]Stavanger[/TD]
[TD] [/TD]
[TD] Venice[/TD]
[TD]Lanzarote[/TD]
[TD]Ajaccio[/TD]
[TD]Vancouver[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]11-Jun-19[/TD]
[TD]Tue[/TD]
[TD]Haugesund[/TD]
[TD]Lisbon[/TD]
[TD]Warnemunde[/TD]
[TD]Flaam[/TD]
[TD] [/TD]
[TD] Zadar[/TD]
[TD] [/TD]
[TD]Barcelona[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]Dublin[/TD]
[/TR]
[TR]
[TD]12-Jun-19[/TD]
[TD]Wed[/TD]
[TD]Skjolden[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]Olden[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]Lisbon[/TD]
[TD] [/TD]
[TD]Ketchikan[/TD]
[TD] [/TD]
[TD]Liverpool[/TD]
[/TR]
[TR]
[TD]13-Jun-19[/TD]
[TD]Thu[/TD]
[TD]Alesund[/TD]
[TD] [/TD]
[TD]Helsinki[/TD]
[TD]Bergen[/TD]
[TD] [/TD]
[TD]Valletta[/TD]
[TD] [/TD]
[TD]Cadiz[/TD]
[TD]Tracy Arm/Juneau[/TD]
[TD] [/TD]
[TD]Cobh[/TD]
[/TR]
[TR]
[TD]14-Jun-19[/TD]
[TD]Fri[/TD]
[TD]Trondheim[/TD]
[TD]Southampton[/TD]
[TD]St Petersburg[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]Messina Strait[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]Skagway[/TD]
[TD]Southampton[/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]15-Jun-19[/TD]
[TD]Sat[/TD]
[TD]Hellesylt[/TD]
[TD] [/TD]
[TD]St Petersburg[/TD]
[TD]Southampton[/TD]
[TD] [/TD]
[TD]Naples[/TD]
[TD]Southampton[/TD]
[TD] [/TD]
[TD]Icy Strait Point[/TD]
[TD] [/TD]
[TD]St Peter Port[/TD]
[/TR]
[TR]
[TD]16-Jun-19[/TD]
[TD]Sun[/TD]
[TD]Geiranger[/TD]
[TD]Santander[/TD]
[TD]Tallinn[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]Civitavecchia[/TD]
[TD] [/TD]
[TD]Southampton[/TD]
[TD]Hubbard Glacier[/TD]
[TD]Hamburg[/TD]
[TD]Southampton[/TD]
[/TR]
[TR]
[TD]17-Jun-19[/TD]
[TD]Mon[/TD]
[TD]Olden[/TD]
[TD]Gijon[/TD]
[TD]Stockholm[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]Ajaccio[/TD]
[TD]Killybegs[/TD]
[TD] [/TD]
[TD]Sitka[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]18-Jun-19[/TD]
[TD]Tue[/TD]
[TD]Bergen[/TD]
[TD]La Coruna[/TD]
[TD] [/TD]
[TD]Cadiz[/TD]
[TD] [/TD]
[TD]Olbia[/TD]
[TD]Greenock[/TD]
[TD]Stavanger[/TD]
[TD] [/TD]
[TD]Zeebrugge[/TD]
[TD]Haugesund[/TD]
[/TR]
[TR]
[TD]19-Jun-19[/TD]
[TD]Wed[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]Copenhagen[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD]Alesund[/TD]
[TD]Victoria[/TD]
[TD]St Peter Port[/TD]
[TD]Olden[/TD]
[/TR]
[TR]
[TD]20-Jun-19[/TD]
[TD]Thu[/TD]
[TD] [/TD]
[TD]St Peter Port[/TD]
[TD] [/TD]
[TD]Barcelona[/TD]
[TD] [/TD]
[TD]Valletta[/TD]
[TD]Torshavn[/TD]
[TD]Olden[/TD]
[TD]Vancouver[/TD]
[TD] [/TD]
[TD]Flaam[/TD]
[/TR]
[TR]
[TD]21-Jun-19[/TD]
[TD]Fri[/TD]
[TD]Southampton[/TD]
[TD]Southampton[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD]Lerwick[/TD]
[TD]Bergen[/TD]
[TD] [/TD]
[TD]Hamburg[/TD]
[TD]Bergen[/TD]
[/TR]
[TR]
[TD]22-Jun-19[/TD]
[TD]Sat[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]Southampton[/TD]
[TD]Monte Carlo[/TD]
[TD] [/TD]
[TD] [/TD]
[TD]Kirkwall[/TD]
[TD] [/TD]
[TD]Ketchikan[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]23-Jun-19[/TD]
[TD]Sun[/TD]
[TD]St Peter Port[/TD]
[TD]St Peter Port[/TD]
[TD] [/TD]
[TD]Livorno[/TD]
[TD] [/TD]
[TD]Livorno[/TD]
[TD] [/TD]
[TD]Southampton[/TD]
[TD]Tracy Arm/Juneau[/TD]
[TD]Southampton[/TD]
[TD]Southampton[/TD]
[/TR]
</tbody>[/TABLE]


Thanks in advance.
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Sort by date Sort by votes
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
 
Upvote 0
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
 
Last edited:
Upvote 0
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.
Click to expand...

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
 
Upvote 0
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
 
Upvote 0
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?
Click to expand...

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
 
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,224,823
Messages
6,181,179
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top