Would the below code be able to be modified to
remove multiple rows based on column headers and cell values, and
do this for multiple column row combinations?
example: Column "Status" Value "Complete"
Cycle through all sheets and look for any header that says status and delete all rows where status has a complete in it?
Sub Delete_Rows_Based_On_Header_and_Value ()
'
' Delete_Rows_Based_On_Header_and_Value Macro
'
' Declaration
Dim a as long
Dim w as long
Dim vDELCOLs as variant
Dim vCOLNDX as variant
Dim vDELROWs as variant
Dim vROWNDX as variant
vDELCOLs = array("status","Status Name","Status Processes")
vDELROWs = array("Complete","Completed","Done")
with Activeworkbook
for w=1 to .worksheets.count
with worksheets(w)
' I know this part is to delete columns based on the column name and I am not sure how to modify it to just check column name then delete row based on the value on that column only.
for a=lbound(vdelcols) to ubound(vdelcols)
vcolndx=application.match(vdelcols(a), .rows(1), 0)
if not iserror(vcolndx) then
.columns(vcolndx).entirecolumn.delete
end if
next a
end with
next w
end with
The following code will take an array of arrays as vDELROWS and will delete a row if any of the values match what is in the corresponding column.
Sub Delete_Rows_Based_On_Header_and_Value()
'
' Delete_Rows_Based_On_Header_and_Value Macro
'
' Declaration
Dim a As Long
Dim w As Long
Dim vDELCOLs As Variant
Dim vCOLNDX As Variant
Dim vDELROWs As Variant
Dim vROWNDX As Variant
Dim r As Long
Dim v As Long
vDELCOLs = Array("status", "Status Name", "Status Processes")
vDELROWs = Array(Array("Complete", "Pending"), Array("Completed", "Pending"), Array("Done"))
With ActiveWorkbook
For w = 1 To .Worksheets.Count
With Worksheets(w)
For a = LBound(vDELCOLs) To UBound(vDELCOLs)
vCOLNDX = Application.Match(vDELCOLs(a), .Rows(1), 0)
If Not IsError(vCOLNDX) Then
For r = .Cells(.Rows.Count, vCOLNDX).End(xlUp).Row To 1 Step -1
For v = LBound(vDELROWs(a)) To UBound(vDELROWs(a))
If .Cells(r, vCOLNDX).Value = vDELROWs(a)(v) Then
.Rows(r).EntireRow.Delete
Exit For
End If
Next
Next
End If
Next a
End With
Next w
End With
End Sub
Autofilter is more efficient than looping
Sub DeleteRows()
Sheet1.Range("a1:c35").AutoFilter Field:=2, Criteria1:="Completed"
Sheet1.UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Sheet1.UsedRange.AutoFilter
'repeat for each value
End Sub
Related
I'm new in VBA and actually don't know how to deal with that task. Maybe you can help me.
I have two tables in two sheets.
Table from sheet 1 is updated daily.
What I need to do is check if any value in column A (sheet 1) is in column A (sheet 2).
If yes, then do nothing.
If no, then copy whole row into the table in sheet 2.
Basing on google results I started to write some code but I stuck.
Dim source As Worksheet
Dim finaltbl As Worksheet
Dim rngsource As Range
Dim rngfinaltbl As Range
'Set Workbook
Set source = ThisWorkbook.Worksheets("Sheet 1")
Set finaltbl = ThisWorkbook.Worksheets("Sheet 2")
'Set Column
Set rngsource = source.Columns("A")
Set rngfinaltbl = finaltbl.Columns("A")
I assume that next I need to write some loop but I really don't know how it works.
Update Worksheet With Missing (Unique) Rows (Dictionary)
Adjust the values in the constants section.
Sub UpdateData()
' Source
Const sName As String = "Sheet1"
Const sFirstCellAddress As String = "A2"
' Destination
Const dName As String = "Sheet2"
Const dFirstCellAddress As String = "A2"
' Reference the destination worksheet.
Dim dws As Worksheet: Set dws = ThisWorkbook.Worksheets(dName)
Dim drg As Range
Dim dCell As Range
Dim drCount As Long
' Reference the destination data range.
With dws.Range(dFirstCellAddress)
Set dCell = .Resize(dws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If dCell Is Nothing Then Exit Sub ' no data in column range
drCount = dCell.Row - .Row + 1
Set drg = .Resize(drCount)
End With
Dim Data As Variant
' Write the values from the destination range to an array.
If drCount = 1 Then
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = drg.Value
Else
Data = drg.Value
End If
' Write the unique values from the array to a dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim Key As Variant
Dim dr As Long
For dr = 1 To drCount
Key = Data(dr, 1)
If Not IsError(Key) Then ' exclude errors
If Len(Key) > 0 Then ' exclude blanks
dict(Key) = Empty
End If
End If
Next dr
' Reference the source worksheet.
Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets(sName)
Dim srg As Range
Dim sCell As Range
Dim srCount As Long
' Reference the source data range.
With sws.Range(sFirstCellAddress)
Set sCell = .Resize(sws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If sCell Is Nothing Then Exit Sub ' no data in column range
srCount = sCell.Row - .Row + 1
Set srg = .Resize(srCount)
End With
' Write the values from the source range to an array.
If srCount = 1 Then
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = srg.Value
Else
Data = srg.Value
End If
Dim surg As Range
Dim sr As Long
' Loop through the source values...
For sr = 1 To srCount
Key = Data(sr, 1)
If Not IsError(Key) Then ' exclude errors
If Len(Key) > 0 Then ' exclude blanks
If Not dict.Exists(Key) Then ' if source value doesn't exist...
dict(Key) = Empty ' ... add it (to the dictionary)...
If surg Is Nothing Then ' and combine the cell into a range.
Set surg = srg.Cells(sr)
Else
Set surg = Union(surg, srg.Cells(sr))
End If
End If
End If
End If
Next sr
' Copy all source rows in one go below ('.Offset(1)') the last cell.
If Not surg Is Nothing Then
surg.EntireRow.Copy dCell.Offset(1).EntireRow
End If
MsgBox "Data updated.", vbInformation
End Sub
No you don't need a loop. You need the Find function for a Range
See Documentation for Find Method (Excel)
also Excel VBA Find A Complete Guide
Trying to just move data to another worksheet for columns with specified column names
Options Explicit
Sub tester()
With ThisWorkbook.Worksheets("Sheet1")
Dim ar As Variant
Dim i As Integer
Dim j As Long
ar = Array("Header1", "Header2") 'define header names to move
For i = 0 To UBound(ar)
j = [A1:AW1].Find(ar(i)).Column
Columns(j).Copy Sheet2.Cells(1, i + 1) 'copy to sheet2 from sheet1
Next I
End With
End Sub
But I still keep running into issues and can't debug.
Specifically - I get a compile error that says "invalid outside procedure". When I delete options explicit, I get the runtime error '13' - type mismatch
Something like this:
Sub tester()
With ThisWorkbook.Worksheets("Sheet1")
Dim ar As Variant
Dim i As Long
Dim j As Long
Dim f As Range
ar = Array("Header1", "Header2") 'define header names to move
For i = 0 To UBound(ar)
Set f = Nothing '<< added
Set f = .Range("A1:AW1").Find(arr(i), lookat:=xlwhole)
If Not f Is Nothing Then
f.EntireColumn.Copy Sheet2.Cells(1, i + 1) '<< entirecolumn
End If
Next i
End With
End Sub
So I'm running a macro to find customer in raw data. Sheet 1 is customer list and sheet 2 is a lot of raw data. In the loop there is a MsgBox that shows if there is a customer in data. The data looks something like this:
How do i get MsgBox to show first value that starts with 4.
Below is the code I'm using.
Public Sub TestMe()
Dim r1 As Variant
Dim r2 As Variant
Dim r3 As Variant
Dim rData As Variant
Dim r As Variant
Dim result As Variant
rData = Application.Transpose(Worksheets(2).Range("A:A"))
r1 = Application.Transpose(Worksheets(1).Range("C2:C33"))
r2 = Application.Transpose(Worksheets(1).Range("C34:C35"))
r3 = Application.Transpose(Worksheets(1).Range("C36:C43"))
For Each r In r1
result = Application.Match(r, rData, 0)
If Not IsError(result) Then
MsgBox r
End If
Next r
For Each r In r2
result = Application.Match(r, rData, 0)
If Not IsError(result) Then
MsgBox r
End If
Next r
For Each r In r3
result = Application.Match(r, rData, 0)
If Not IsError(result) Then
MsgBox r
End If
Next r
MsgBox "search ended."
End Sub
Try like this:
Public Sub TestMe()
Dim bigRange As Range
Dim myCell As Range
Set bigRange = Worksheets(2).Range("A1:A9")
For Each myCell In bigRange
If Left(myCell, 1) = 4 Then
MsgBox myCell
Exit For
End If
Next myCell
End Sub
It will simply loop through the cells in the bigRange and check whether the first character of the cell is 4. If it is 4, it shows the MsgBox and it exits the loop.
I think you want something along these lines. At a high level the code loops cell in the 1st column of your first sheet, to extract the customer ids. Each id is searched for in the second sheet. If found we work our way up (using the offset property) looking for a cell starting 4.
Sub findCustomer()
Dim customerWs As Worksheet ' Ref to the customer worksheet.
Dim rawWs As Worksheet ' Ref to the raw worksheet.
Dim currentCustomer As Range ' Used to loop over all customers.
Dim findCustomer As Range ' Used to search raw for current customer.
Dim offsetRow As Integer ' Used to search above found customer for value starting 4.
Set customerWs = ThisWorkbook.Sheets("Sheet1")
Set rawWs = ThisWorkbook.Sheets("Sheet2")
' Assumes all customer ids are located in the first column
' of sheet 1.
' Loop executed once for each cell in that column.
For Each currentCustomer In customerWs.UsedRange.Columns(1).Cells
' Look for the current customer.
Set findCustomer = rawWs.Columns(1).Find(currentCustomer.Value)
If Not findCustomer Is Nothing Then
' Found one.
' Work up one row at a time looking for 4.
For offsetRow = 1 To (findCustomer.Row - 1)
If findCustomer.Offset(offsetRow * -1, 0).Value Like "4*" Then
' Match found.
' Inform user and exit.
MsgBox "Customer: " & findCustomer.Value & ". 4 Found: " & findCustomer.Offset(offsetRow * -1, 0).Address & "."
Exit For
End If
Next
End If
Next
End Sub
I am trying to run a macro on 3 different ranges, one after another. Once the range is selected, the code works just fine (where variables F and L are defined). I would like to set r1-r3 as Ranges I need and then use a string variable to concatenate the range numbers together. This code works, but doesn't provide the starting and ending row number in the range selected. This is vital because it tells the "TableCalc" macro when to start and stop the code. I would then like to move on to the next range. Thanks for your help.
Sub TestRangeBC()
WS.Select
Dim r1 As Range
Dim r2 As Range
Dim r3 As Range
Dim rngx As String
Dim num As Integer
Dim rng As Range
Set r1 = WS.Range("ONE")
Set r2 = WS.Range("TWO")
Set r3 = WS.Range("THREE")
For num = 1 To 3
rngx = "r" & num
Set rng = Range(rngx)
Dim F As Integer
Dim L As Integer
F = rng.Row + 1
L = rng.Row + rng.Rows.Count - 2
Cells(F, 8).Select
Do While Cells(F, 8) <> "" And ActiveCell.Row <= L
'INSERT SITUATIONAL MACRO
Call TableCalc
WS.Select
ActiveCell.Offset(1, 0).Select
Loop
Next num
End Sub
This is not the answer (as part of your code and what you are trying to achieve is unclear yet), but it is a "cleaner" and more efficient way to code what you have in your original post.
Option Explicit
Dim WS As Worksheet
Your original Sub shorten:
Sub TestRangeBC()
' chanhe WS to your Sheet name
Set WS = Sheets("Sheet1")
Call ActiveRange("ONE")
Call ActiveRange("TWO")
Call ActiveRange("THREE")
End Sub
This Sub gets the Name of the Named Range (you set in your workbook) as a String, and sets the Range accordingly.
Sub ActiveRange(RangeName As String)
Dim Rng As Range
Dim F As Integer
Dim L As Integer
Dim lRow As Long
With WS
Set Rng = .Range(RangeName)
' just for debug purpose >> to ensure the right Range was passed and set
Debug.Print Rng.Address
F = Rng.Row + 1
L = Rng.Row + Rng.Rows.Count - 2
lRow = F
' what you are trying to achieve in this loop is beyond me
Do While .Cells(F, 8) <> "" And .Cells(lRow, 8).Row <= L
Debug.Print .Cells(lRow, 8).Address
'INSERT SITUATIONAL MACRO
' Call TableCalc
' not sure you need to select WS sheet again
WS.Select
lRow = lRow + 1
Loop
End With
End Sub
What are you trying to test in the loop below, what are the criteria of staying in the loop ?
Do While Cells(F, 8) <> "" And ActiveCell.Row <= L
it's really hard to tell what you may want to do
but may be what follows can help you clarifying and (hopefully) doing it!
first off, you can't "combine" variable names
So I'd go with an array of named ranges names (i.e. String array) to be filled by means of a specific sub:
Function GetRanges() As String()
Dim ranges(1 To 3) As String
ranges(1) = "ONE"
ranges(2) = "TWO"
ranges(3) = "THREE"
GetRanges = ranges
End Function
so that you can clean up your "main" sub code and keep only more relevant code there:
Sub TestRangeBC()
Dim r As Variant
Dim ws As Worksheet
Set ws = Worksheets("Ranges") '<--| change "Ranges" to your actual worksheet name
For Each r In GetRanges() '<--| loop through all ranges names
DoIt ws, CStr(r) '<--| call the range name processing routine passing worksheet and its named range name
Next r
End Sub
the "main" sub loops through the named ranges array directly collected from GetRanges() and calls DoIt() to actually process the current one:
Sub DoIt(ws As Worksheet, rangeName As String)
Dim cell As Range
Dim iRow As Long
With ws.Range(rangeName) '<--| reference the passed name passed worksheet named range
For iRow = .Rows(2).Row To .Rows(.Rows.Count - 2).Row '<--| loop through its "inner" rows (i.e. off 1st and last rows)
Set cell = ws.Cells(iRow, 8) '<--| get current row corresponding cell in column "F"
If cell.value = "" Then Exit For '<--| exit at first blank column "F" corresponding cell
TableCalc cell '<-- call TableCalc passing the 'valid' cell as its parameter
Next iRow
End With
End Sub
I have compiled this code from bit and pieces I have found - I am by no means an expert - more of an eager student - This code works for me but now I need to keep the first occurrence of the duplicate row to stay on the original worksheet and move only the subsequent occurrence(s) to the newly created sheet.
I am willing to redo all the code if needed but would prefer to modify the existing vba for the sake of time
Sub moveduplicates
'***************************************************************
'** This proc expects you to select all the cells in a single **
'** column that you want to check for duplicates in. If dup- **
'** licates are found, the entire row will be copied to the **
'** predetermined sheet. **
'***************************************************************
Set Rng = ActiveCell
'Sticky_Selection()
Dim s As Range
Set s = Selection
Cells.EntireColumn.Hidden = False
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Duplicate Values"
Sheets("Data").Select
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("Duplicate Values").Select
Range("A1").Select
ActiveSheet.Paste
s.Parent.Activate
s.Select 'NOT Activate - possibly more than one cell!
Dim ShO As Worksheet
Dim Rng1 As Range
Dim pRow As Integer
Dim c As Range, cTmp As Range
Dim found
Dim Addresses() As String
Dim a() As String
Dim p2 As Integer
Dim tfFlag As Boolean, sTmp As Variant
Set ShO = Worksheets("Duplicate Values") 'You can change this to whatever worksheet name you want the duplicates in Set Rng1 = Application.InputBox("Select a range", "Obtain Range Object", Type:=8)
MsgBox "The cells selected were " & Rng.Address 'Rng1 is all the currently selected cells
pRow = 2 'This is the first row in our output sheet that will be used to record duplicates
ReDim a(0) 'Initialize our array that holds found values
For Each c In Rng1.Cells 'Cycle through each cell in our selected range
ReDim Addresses(0) 'This array holds the cell address for our duplicates.
'We will reset the array each time we move to the next cell
Now check the array of already found duplicates.
If the current value is already there skip to next value
tfFlag = False
For Each sTmp In a
If CStr(c.Value) = sTmp Or CStr(c.Value) = "xXDeleteXx" Then 'We've already done this value, move on
tfFlag = True
Exit For
End If
Next
If Not tfFlag Then 'Remember the flag is true when we have already located the
'duplicates for this value, so skip to next value
With Rng1
Set found = .Find(c.Value, LookIn:=xlValues) 'Search entire selected range for value
If Not found Is Nothing Then 'Found it
Addresses(0) = found.Address 'Record the address we found it
Do 'Now keep finding occurances of it
Set found = .FindNext(found)
If found.Address <> Addresses(0) Then
ReDim Preserve Addresses(UBound(Addresses) + 1)
Addresses(UBound(Addresses)) = found.Address
End If
Loop While Not found Is Nothing And found.Address <> Addresses(0) 'Until we get back to the original address
If UBound(Addresses) > 0 Then 'We Found Duplicates
a(UBound(a)) = c.Value 'Record the value we found a duplicate for in an array
'ReDim Preserve a(UBound(a) + 1) 'add an empty spot to the array for next value
'ShO.Range("A" & pRow).Value = "Duplicate Rows for Value " & c.Value & _
" in Column " & c.Column & " on original sheet" 'Add a label row
'pRow = pRow + 1 'Increment to the next row
For p2 = UBound(Addresses) To 0 Step -1 'Cycle through the duplicate addresses
Set cTmp = Rng1.Worksheet.Range(Addresses(p2)) 'we just want to easily get the correct row to copy
Rng1.Worksheet.Rows(cTmp.Row).Copy ShO.Rows(pRow) 'Copy form orig to duplicates sheet
cTmp.Value = "xXDeleteXx" 'Mark for Delete the original row
pRow = pRow + 1 'Increment row counter
Next p2
'Row = pRow + 1 'This increment will give us a blank row between sets of duplicates
End If
End If
End With
End If
Next
'Now go delete all the marked rows
Do
tfFlag = False
For Each c In Rng1
If c.Value = "xXDeleteXx" Then
Rng1.Worksheet.Rows(c.Row).Delete (xlShiftUp)
tfFlag = True
End If
Next
Loop Until tfFlag = False
'AutoFit Every Worksheet Column in a Workbook
For Each sht In ThisWorkbook.Worksheets
sht.Cells.EntireColumn.AutoFit
Next sht
Application.Goto Rng
End
End Sub
Thank you very much for your time and consideration
You can use a scripting Dictionary object to keep track of duplicates:
Sub RemoveDups()
Dim c As Range, dict, rngDel As Range, rw As Long
Dim wb As Workbook
Dim shtDups As Worksheet
Dim rng1 As Range
Set rng1 = Selection 'assuming you've selected a single column of values
' from which you want to remove dups
Set wb = ActiveWorkbook
Set shtDups = wb.Worksheets.Add( _
after:=wb.Worksheets(wb.Worksheets.Count))
shtDups.Name = "Duplicate Values"
With rng1.Parent
.Range(.Range("A2"), .Range("A2").End(xlToRight)).Copy _
shtDups.Range("A1")
End With
rw = 2
Set dict = CreateObject("scripting.dictionary")
For Each c In rng1.Cells
'already seen this value?
If dict.exists(c.Value) Then
c.EntireRow.Copy shtDups.Cells(rw, 1)
rw = rw + 1
'add row to "delete" range
If rngDel Is Nothing Then
Set rngDel = c
Else
Set rngDel = Application.Union(c, rngDel)
End If
Else
'first time for this value - add to dictionary
dict.Add c.Value, 1
End If
Next c
'delete all duplicate rows (if found)
If Not rngDel Is Nothing Then
rngDel.EntireRow.Delete
End If
End Sub
Another enthusiastic amateur here!
Not really answering your question, but here is a little function I use for removing duplicate rows:
Sub RemoveDupes(TempWB As Workbook, TargetSheet As String, ConcatCols As String, DeleteTF As Boolean)
Dim Counter As Integer
Dim Formula As String
Dim RowCount As Integer
Dim StartingCol As String
Dim CurrentRow As Integer
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Remove duplicate rows on a worksheet '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Prerequisites:
' - Data needs to start # A1
' - Data has headings in row 1
' determine number of rows to be processed
RowCount = TempWB.Sheets(TargetSheet).Cells(TempWB.Sheets(TargetSheet).Rows.Count, "A").End(xlUp).Row
' insert a column to hold the calculate unique key
TempWB.Sheets(TargetSheet).Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
' add a heading
TempWB.Sheets(TargetSheet).Cells(1, 1).Value = "Duplication Check"
' insert the unique key formula
For CurrentRow = 2 To RowCount
' start the formula string
Formula = "="
' construct the formula
For Counter = 1 To Len(ConcatCols)
' if we are on the last element, dont add another '&'
If Counter = Len(ConcatCols) Then
Formula = Formula & AddLetter(Mid(ConcatCols, Counter, 1)) & CurrentRow
Else
Formula = Formula & AddLetter(Mid(ConcatCols, Counter, 1)) & CurrentRow & "&"
End If
' Debug.Print Mid(ConcatCols, Counter, 1)'Next
' next element!
Next
' insert the newly constructed formula
TempWB.Sheets(TargetSheet).Cells(CurrentRow, "A").Formula = Formula
' next row
Next
' unfortunately we need to use explicit selection here *sigh*
TempWB.Sheets(TargetSheet).Activate
' to select the range we are going to test
TempWB.Sheets(TargetSheet).Range("A2:A" & TempWB.Sheets(TargetSheet).Cells(Rows.Count, "A").End(xlUp).Row).Select
' clock down the list flagging each dupe by changing the text color
Dim d As Object, e
Set d = CreateObject("scripting.dictionary")
For Each e In Intersect(Columns(ActiveCell.Column), ActiveSheet.UsedRange)
If e.Value <> vbNullString Then
If Not d.exists(e.Value) Then d(e.Value) = 1 Else _
e.Font.ColorIndex = 4
End If
Next
' if the delete flag is set...
If DeleteTF Then
' then go down the list deleting rows...
For CurrentRow = RowCount To 2 Step -1
' if the row has been highlighted, its time to go...
If TempWB.Sheets(TargetSheet).Cells(CurrentRow, "A").Font.ColorIndex = 4 Then
TempWB.Sheets(TargetSheet).Cells(CurrentRow, "A").EntireRow.Delete
End If
Next
' If we are deleting rows, remove the column just like we were never here
TempWB.Sheets(TargetSheet).Cells(1, "A").EntireColumn.Delete
End If
End Sub
Function AddLetter(Letter As String)
' gives you the next letter
AddLetter = Split(Cells(, Range(Letter & 1).Column + 1).Address, "$")(1)
End Function
When I get a sec I will have a go adapting this to your requirements...
This will search a specified column for duplicates, copying subsequent duplicates entries to Sheet2 and then remove them from Sheet1.
I've used the Scripting Dictionary too but you will need to add a reference to "Microsoft Scripting Runtime" for the code to work as-is. (Adding the reference will help if you want to learn about dictionaries since it adds the Dictionary to Intellitype code completion stuff)
Sub Main()
Dim SearchColumn As Integer: SearchColumn = 2 ' column to search for duplicates
Dim Source As Worksheet: Set Source = ThisWorkbook.Worksheets("Sheet1")
Dim Duplicates As Worksheet: Set Duplicates = ThisWorkbook.Worksheets("Sheet2")
Dim List As Dictionary: Set List = New Dictionary ' used to hold the first instance of unique items
Dim Data As Variant ' holds a copy of the column you want to search
Dim Count As Integer ' hold the size of said column
Dim Index As Integer ' iterator for data
Dim Item As String ' holds the current item
Count = Source.Cells(Source.Rows.Count, SearchColumn).End(xlUp).Row
Set Data = Source.Range(Source.Cells(1, SearchColumn).Address, Source.Cells(Count, SearchColumn).Address)
Application.ScreenUpdating = False
' first loop, find unique items and copy duplicates
For Index = 1 To Count
Item = Data(Index, 1)
If List.Exists(Item) = False Then
' add the item to our dictionary of items
List.Add Item, Index
Else
' add item to duplicates sheet as its a duplicate
Source.Rows(Index).Copy
Duplicates.Rows(1).Insert xlShiftDown
End If
Next Index
' second loop, remove duplicates from original sheet
For Index = Count To 1 Step -1
Item = Data(Index, 1)
If List.Exists(Item) Then
If Not List(Item) = Index Then
' the item is a duplicate and needs to be removed
Source.Rows(Index).Delete
End If
End If
Next Index
Application.ScreenUpdating = True
End Sub