I have a list with 3 columns
I want to delete any duplicate value with no shifting, the duplicated values can be both on the first column and on the second.
How can I do that?
I've tried something but it didn't work
Sub RemoveDuplicates()
Dim rng As Range
Dim x As Long
Dim lRow As Long
Dim i As Integer
Columns("B:C").Select
Range("C1").Activate
Selection.Replace What:="-", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="0", Replacement:="0", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
i = 1
x = 1
Do While Cells(i, 1).Value <> ""
Cells(i, 4) = "=CONCATENATE(0,RC[-2])"
i = i + 1
Loop
Do While Cells(x, 1).Value <> ""
Cells(x, 5) = "=CONCATENATE(0,RC[-2])"
x = x + 1
Loop
Columns("D:E").Select
Application.CutCopyMode = False
Selection.Copy
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("D:E").ClearContents
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
With ThisWorkbook.Sheets(1)
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set rng = ThisWorkbook.Sheets(1).Range("B2:C" & lRow)
End With
For x = rng.Cells.Count To 1 Step -1
If WorksheetFunction.CountIf(rng, rng(x)) > 1 Then
rng(x).ClearContents
End If
Next x
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Try this where your two columns are B and C. It loops through all of the data and uses the worksheet function COUNTIF to check if there is more than one occurrence of each value and clears the contents of the cell if there is a count of more than 1:
Sub RemoveDuplicates()
Dim rng As Range
Dim x as Long
Dim lRow as Long
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
With Thisworkbook.Sheets("SheetName")
lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set rng = .Range("B2:C" & lRow)
End With
For x = rng.Cells.Count To 1 Step -1
If WorksheetFunction.CountIf(rng, rng(x)) > 1 Then
rng(x).ClearContents
End If
Next x
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Related
everyone. I am newie on this, but i need this so i am asking for your help.
I am building a macro to copy filtered data from several books to a consolitation one. The following code run fine until one filtered worksheet has no result rows, then it copy a range of empty cells, in that moment a receive an error 1004 that a can't solve. This is my code (result of several adaptation of code to my need):
Sub MergeDataFromWorkbooks()
Dim wbk As Workbook
Dim wbk1 As Workbook
Set wbk1 = ThisWorkbook
Dim Filename As String
Dim Path As String
Path = "D:\Reportes\Prueba\"
Filename = Dir(Path & "*.xlsx")
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Do While Len(Filename) > 0
Set wbk = Workbooks.Open(Path & Filename)
wbk.Activate
If ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
With ActiveSheet
.AutoFilterMode = False
.Range("B6:BB6").AutoFilter field:=8, Criteria1:="*Nacional*"
End With
Range("B7").Select
Range(Selection, "BA7").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Windows("Merged.xlsm").Activate
Application.DisplayAlerts = False
Dim lr As Double
lr = wbk1.Sheets(1).Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
'Sheets("Hoja1").Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Sheets("Hoja1").Select
Cells(lr + 1, 1).Select
ActiveCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True
Application.CutCopyMode = False
wbk.Close True
Filename = Dir
Loop
MsgBox "All the files are copied and pasted in Merged."
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
you have to check whether there are any filtered cells, so wrap copy/paste statements inside some If - Then as follows:
With ActiveSheet
.AutoFilterMode = False
.Range("B6:BB6").AutoFilter field:=8, Criteria1:="*Nacional*"
End With
If Application.WorksheetFunction.Subtotal(103, Intersect(ActiveSheet.UsedRange, Columns(2))) > 1 Then
Range("B7").Select
Range(Selection, "BA7").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.copy
Windows("Merged.xlsm").Activate
Application.DisplayAlerts = False
Dim lr As Double
lr = wbk1.Sheets(1).Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).row
'Sheets("Hoja1").Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Sheets("Hoja1").Select
Cells(lr + 1, 1).Select
ActiveCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True
Application.CutCopyMode = False
End If
wbk.Close True
Filename = Dir
Check for visible values in the filtered range before copying.
With ActiveSheet
.AutoFilterMode = False
with .Range("B6:BB6")
.AutoFilter field:=8, Criteria1:="*Nacional*"
with .resize(.rows.count-1, .columns.count).offset(1, 0)
if cbool(application.subtotal(103, .cells)) then
.SpecialCells(xlCellTypeVisible).copy
end if
end with
end with
End With
It's probably better to work out the destination beforehand and use the Destination parameter of the copy operation.
I have a problem with my VBA code. The problem is that I have duplicate names - the main sheet "Manager" and the names of the sheets.
The code should go to every sheet and look for the value "Engagements ID" and then go one cell down. In every sheet the number of Engagements ID is different, so the code should search in every sheet (500 rows) - look for the value "Engagements ID" then copy and paste the cell what is one row below into my main sheet, which is called "Manager".
Thank you for help!! :) The value what I looking for is on every sheet in column B.
This is my code:
Option Explicit
Sub Check_Account()
Dim rng As Range
Dim xName As String
Dim i, j As Integer
For i = 3 To 6
xName = Cells(i, 1)
If xName = "" Then Exit Sub
On Error Resume Next
ActiveWorkbook.Sheets(xName).Select
Sheets(xName).Select
For j = 1 To 500
If rng.Cells(j, 2) = "Engagements ID" Then
rng.Offset(1, 0).Select
Selection.Copy
Sheets("Manager").Select
If Range("B" & i) = "" Then
Range("B" & i).Select
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWorkbook.Sheets(xName).Select
Sheets(xName).Select
Cells(j, 2).Offset(1, 0).Select
Else
Range("B" & i).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWorkbook.Sheets(xName).Select
Sheets(xName).Select
Cells(j, 2).Offset(1, 0).Select
End If
End If
Next j
On Error GoTo 0
Next i
End Sub
Please try this code. I think you will like it.
Option Explicit
Sub Check_Account()
' 24 Nov 2017
Dim TabName As String
Dim Rng As Range
Dim Fnd As Range
Dim Rl As Long ' last row
Dim FirstFnd As Long
Dim i As Integer
For i = 3 To 6
' Tab names are found at Manager!A3:A6
TabName = Worksheets("Manager").Cells(i, "A").Value
If Len(TabName) = 0 Then Exit For
On Error Resume Next
With Worksheets(TabName)
If Err Then
MsgBox "Worksheet """ & TabName & """ doesn't exist.", _
vbInformation, "Missing Worksheet"
Else
Rl = .Cells(.Rows.Count, "B").End(xlUp).Row
Set Rng = Range(.Cells(1, "B"), .Cells(Rl, "B"))
Set Fnd = Rng.Find("Engagements ID", _
After:=Rng.Cells(Rng.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
MatchByte:=False)
If Not Fnd Is Nothing Then
FirstFnd = Fnd.Row
Do
With Worksheets("Manager")
Rl = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
' start writing in row 2
If Rl < 2 Then Rl = 2
.Cells(Rl, "B").Value = Fnd.Offset(1).Value
End With
Set Fnd = Rng.FindNext(Fnd)
Loop While Not Fnd Is Nothing And Fnd.Row <> FirstFnd
End If
End If
End With
Next i
End Sub
I have tried and tested the code below, and I believe it does what you expected it to do:
Sub foo()
For i = 3 To 6
xName = Sheets("Manager").Cells(i, 1).Value
LastRow = Sheets(xName).Cells(Sheets(xName).Rows.Count, "B").End(xlUp).Row
For x = 1 To LastRow
If Sheets(xName).Cells(x, 2).Value = "Engagements ID" Then
Sheets("Manager").Cells(i, 2).Value = Sheets(xName).Cells(x + 1, 2).Value
End If
Next x
Next i
End Sub
This does not have any validation against possible errors, if the manager sheet does not exist, then you will get an error... But at least the code is more concise and it points you in the right direction.
I have a macro that does work, it's just really slow when there is a lot of data and I'm hoping that someone on here can help me to speed it up.
When my VBA does is check the columns of a sheet for the value "NULL" and if it's there it clears that cell. Here's the code:
Sub RemoveNullColumn()
Dim c, count, r, lc, FirstCell
Application.ScreenUpdating = False
count = 0
r = ActiveCell.row 'lets you choose where you want to start even if it is not at "A1"
c = ActiveCell.Column 'lets you choose where you want to start even if it is not at "A1"
c = GetLetterFromNumber(c) 'Gets the column letter from the number provided above
FirstCell = c & r 'sets the cell that you selected to start in so that you will end thereafter removing all the NULL
lc = ActiveSheet.Cells(1, Columns.count).End(xlToLeft).Column 'Finding the last used column
For H = ActiveCell.Column To lc Step 1 'Starts with where you selected a cell and moves right to the last column
For x = 1 To Range(c & Rows.count).End(xlUp).row Step 1 'Starts with the first row and moves through the last row
count = count + 1
If Range(c & x).Value = "NULL" Then 'Checks the contents fo the cell to see if it is "NULL"
Range(c & x).Clear
End If
If count = 1000 Then 'This was used testing but is not seen with the ScreenUpdating set to false
Range(c & x).Select
count = 1
End If
Next x
ActiveCell.Offset(0, 1).Select 'select the next column
c = ActiveCell.Column
c = GetLetterFromNumber(c) 'get the letter of the next column
Next H
Application.ScreenUpdating = True
MsgBox "Finished"
Range(FirstCell).Select
End Sub
Function GetLetterFromNumber(Number)
GetLetterFromNumber = Split(Cells(1, Number).Address(True, False), "$")(0)
End Function
When there are not a lot of rows it is pretty fast, but there are a lot of rows it is slow.
I have a file that I ran it on that has columns from A to AD and 61k+ rows, it took more than 30 minutes to finish and I'm hoping to make that much faster.
Instead of looking into Every single cell in the worksheet, use Replace function which is far faster :(you may need to edit it customize it to your needs)
Example :
Sub RemoveNullColumn()
Dim targetSheet As Worksheet
Set targetSheet = ActiveSheet 'TODO: replace with a stronger object reference
targetSheet.Cells.Replace What:="NULL", Replacement:="", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End Sub
This will make sure you will preserve the format.
If you want to clear NULL using ActiveCell as reference:
Range(ActiveCell, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Replace What:="NULL", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False, _
ReplaceFormat:=False
Please give this a try...
Sub RemoveNullColumn()
Dim lr As Long, lc As Long
Dim rng As Range, cell As Range, FirstCell As Range
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
lr = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lc = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Set FirstCell = ActiveCell
Set rng = Range(Cells(1, FirstCell.Column), Cells(lr, lc))
For Each cell In rng
If cell.Value = "NULL" Then
cell.Clear
End If
Next cell
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
MsgBox "Finished"
End Sub
Use a .Find/.FindNext to collect all of the matching cells into a Union then clear the contents of the Union'ed cells.
Option Explicit
Sub noNULLs()
Dim firstAddress As String, c As Range, rALL As Range
With ActiveSheet.Cells 'This should be named worksheet like Worksheets("sheet1")
Set c = .Find("NULL", MatchCase:=True, _
LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
Set rALL = c
firstAddress = c.Address
Do
Set rALL = Union(rALL, c)
Set c = .FindNext(c)
Loop While c.Address <> firstAddress
rALL.Clear
End If
End With
End Sub
How can I highlight a single row a color if text in column A = X
Using Row 4 as an example:
What i'm ultimately trying to get is if Cell in Column A is = X then change row color from Range("B4:N4") to Black And Text.Color to White from Range("F4:N4")
Ultimately I would want it to be something like Range(Cells(i, "B"), Cells(LastRow, LastCol)) but only color one row.
This is what i am working with so far.
Sub Header()
Application.ScreenUpdating = False
Dim sht2 As Worksheet
Set sht2 = ThisWorkbook.Worksheets("Email Form")
sht2.Activate
sht2.Unprotect
Dim LastRow As Long, LastCol As Long
Dim rng As Range, c As Range
Dim WholeRng As Range
Dim i As Integer
On Error GoTo 0
With sht2
Set rng = .Cells
LastRow = rng.Find(What:="*", After:=rng.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
LastCol = rng.Find(What:="*", After:=rng.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
'MsgBox wholerng.Address
Set WholeRng = Range(Cells(i, "B"), Cells(LastRow, LastCol)).Rows
For i = 4 To LastRow
If sht2.Cells(i, 1).Value = "X" Then
With WholeRng
With .Interior
.PatternColorIndex = xlAutomatic
.Color = 1
.TintAndShade = 0
.Font.Color = 0
End With
End With
End If
Next i
Dim b As Boolean
For Each rng In WholeRng.Rows
If Not rng.Hidden Then
If b Then rng.Interior.Color = 1
b = Not b
End If
Next
End With
Set sht2 = Nothing
Set rng = Nothing
Set WholeRng = Nothing
Application.ScreenUpdating = False
End Sub
VBA Conditional Formatting.
Option Explicit
Sub Header()
Dim sht2 As Worksheet
Dim firstRow As Long, lastRow As Long, lastCol As Long
'Application.ScreenUpdating = false
On Error GoTo 0
Set sht2 = ThisWorkbook.Worksheets("Email Form")
firstRow = 4
With sht2
.Activate
.Unprotect
lastRow = .Cells.Find(What:="*", After:=.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
lastCol = .Cells.Find(What:="*", After:=.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
'black row, white text B:N
With .Range(.Cells(firstRow, "B"), .Cells(lastRow, lastCol))
'optionally remove any pre-existing CFRs
.FormatConditions.Delete
With .FormatConditions.Add(Type:=xlExpression, Formula1:="=UPPER($A4)=CHAR(88)")
.Interior.ThemeColor = xlThemeColorLight1
.Font.ThemeColor = xlThemeColorDark1
.SetFirstPriority
.StopIfTrue = False
End With
End With
'don't display values from B:E
With .Range(.Cells(firstRow, "B"), .Cells(lastRow, "E"))
With .FormatConditions.Add(Type:=xlExpression, Formula1:="=UPPER($A4)=CHAR(88)")
.NumberFormat = ";;;"
End With
End With
'I tnhink you want to reProtect the worksheet here
.Protect
End With
Application.ScreenUpdating = True
End Sub
I think you can achieve your goal using Conditional Formatting:
You can create a condition for each format setting for the two different ranges.
Select one range at a time, then from the Home tab, create a New Conditional Formatting Rule, choose to Use a Formula and then enter a formula like:
=$A2="X"
Note that when using relative/mixed references in conditional formatting, it will be compared to the first cell in the range you are working with. I've selected range B2:N7 to apply formatting to, so the mixed reference needs to be created as it should apply to the B2 cell. You can't see it, but the reference automatically changes for all other cells in the same range, the same as if you were filling a formula across the rest of the range. For example, the formatting for the K5 cell will be dependent on the value in $A5 (because the column reference is fixed but the row reference is dynamic).
Then set the background colour or font colour you want for the range specified. This condition will check column A of the corresponding row.
I re-wrote some of your code and added comments to show you why. But by and large, I followed your original approach.
Sub Header()
Dim Sht2 As Worksheet
Dim LastRow As Long, LastCol As Long
Dim IsBlack As Boolean, FillPattern As Long
Dim Rng As Range
Dim R As Long
' Set sht2 = ThisWorkbook.Worksheets("Email Form")
Set Sht2 = ThisWorkbook.Worksheets("Taylor")
' On Error GoTo 0 ' this is the default: no need to set
Application.ScreenUpdating = False
With Sht2
.Activate ' no need to activate this sheet
.Unprotect
' this is the whole sheet: Easier to refer to it as .Cells
' Set rng = .Cells
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
' LastRow = Rng.Find(What:="*", After:=Rng.Cells(1), Lookat:=xlPart, _
' LookIn:=xlFormulas, SearchOrder:=xlByRows, _
' SearchDirection:=xlPrevious, MatchCase:=False).Row
' LastCol = Rng.Find(What:="*", After:=Rng.Cells(1), Lookat:=xlPart, _
' LookIn:=xlFormulas, SearchOrder:=xlByColumns, _
' SearchDirection:=xlPrevious, MatchCase:=False).Column
' MsgBox "Last row = " & LastRow & vbCr & _
' "Last column = " & LastCol
For R = 4 To LastRow
IsBlack = Not CBool(StrComp(.Cells(R, 1).value, "X", vbTextCompare))
FillPattern = CLng(Array(xlNone, xlSolid)(Abs(IsBlack)))
Set Rng = .Range(.Cells(R, 1), .Cells(R, LastCol))
With Rng.Interior
If .Pattern <> FillPattern Then
.Pattern = FillPattern
If IsBlack Then
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
End If
.TintAndShade = 0
.PatternTintAndShade = 0
Rng.Font.ColorIndex = Array(xlAutomatic, 2)(Abs(IsBlack))
End If
End With
Next R
End With
' VBA does this cleanup automatically at the end of the sub
' Set sht2 = Nothing
' Set Rng = Nothing
Application.ScreenUpdating = False
End Sub
I try to sort a sheet in my workbook. After the macro sorted my table it should remove all duplicates based on the column A.
But every time I use the macro, I get the following error:
Sub SortAndRemoveDUBS()
Dim Rng As Range
Dim LastRow As Long
Dim i As Long
Application.ScreenUpdating = False
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
Set Rng = Range("A4:P" & LastRow)
With Rng
.Sort Key1:=Range("A4"), Order1:=xlAscending, key2:=Range("P4"), order2:=xlDescending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End With
Dim arr() As Variant
Dim cnt As Long
cnt = 0
For i = LastRow To 2 Step -1
If WorksheetFunction.CountIf(Range(Cells(2, "A"), Cells(i, "A")), Cells(i, "A")) > 1 Then
ReDim Preserve arr(cnt)
arr(cnt) = i
cnt = cnt + 1
End If
Next i
If Len(Join(arr)) > 0 Then ActiveSheet.Range("A" & Join(arr, ",A")).EntireRow.Delete
Application.ScreenUpdating = True
End Sub
This line gets highlighted:
ActiveSheet.Range("A" & Join(arr, ",A")).EntireRow.Delete
Does someone see what the probleme is?
Use RemoveDuplicates()
and, since you remove all duplicates from column "A" either you sort on column "A" or on column "P": I assume you need this latter
Sub SortAndRemoveDUBS()
With Worksheets("MyDataSheet") '<--| change "MyDataSheet" to your actual worksheet name
With Range("A4:P" & .Cells(.Rows.Count, "B").End(xlUp).Row)
.RemoveDuplicates Columns:=Array(1)
.Sort Key1:=Range("P4"), order1:=xlDescending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End With
End With
End Sub
If you want to remove all duplicates except the first one then this code will work in 2007+:
Sub SortAndRemoveDUBS()
Dim Rng As Range
Dim LastRow As Long
Application.ScreenUpdating = False
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
Set Rng = Range("A4:P" & LastRow)
With Rng
.Sort Key1:=Range("A4"), Order1:=xlAscending, key2:=Range("P4"), order2:=xlDescending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
End With
Rng.RemoveDuplicates Columns:=1, Header:=xlYes
Application.ScreenUpdating = True
End Sub
Edit:
If you want to remove all duplicates this code will do the job:
Sub SortAndRemoveDUBS()
Dim Rng As Range
Dim LastRow As Long
Dim i As Long
Dim RngToDelete As Range
Application.ScreenUpdating = False
LastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row
Set Rng = ThisWorkbook.Worksheets("Sheet1").Range("A4:P" & LastRow)
With Rng
.Sort Key1:=Range("A4"), Order1:=xlAscending, key2:=Range("P4"), order2:=xlDescending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
For i = LastRow To 4 Step -1
If WorksheetFunction.CountIf(.Resize(, 1), .Cells(i - 3, 1)) > 1 Then
If RngToDelete Is Nothing Then
Set RngToDelete = .Cells(i - 3, 1).EntireRow
Else
Set RngToDelete = Union(RngToDelete, .Cells(i - 3, 1).EntireRow)
End If
End If
Next i
End With
If Not RngToDelete Is Nothing Then
RngToDelete.Delete
End If
Application.ScreenUpdating = True
End Sub
Try using Application.WorksheetFunction.Match method
Example
Option Explicit
Sub Function_Match()
Dim vRow As Variant
Dim i As Long, LastRow As Long
LastRow = WorksheetFunction.CountA(Columns(1))
For i = LastRow To 2 Step -1
vRow = Application.Match(Cells(i, 1).Value, Range(Cells(1, 1), Cells(i - 1, 1)), 0)
If Not IsError(vRow) Then
Rows(vRow).Delete
End If
Next
End Sub