[RESOLVED] highlight duplicate rows include original instance.
I want all the duplicate rows highlighted in a worksheet along with original instance e.g. if I have row 1 with some data in multiple columns and the same date appears on row 20 then the macro should highlight both the row items in some same color. I got the below code through google search but when it try to run it gets stuck on the below line and shows error Run time Error '13' type mismatch. Excel version used by me is excel 2010. can someone help.
Code:
NewStr1 = NewStr1 & "||" & ws1.Cells(Row1.Row, Col1.Column) ' it's throwing runtime error on this line.
Code:
Option Explicit
Sub HighDupes()
Dim ws1 As Worksheet
Dim Row1 As Range
Dim Col1 As Range
Dim NewStr1 As String
'Needs reference to Microsoft Scripting Runtime
Dim MyDic As Dictionary
Set MyDic = New Dictionary
Set ws1 = ActiveWorkbook.Sheets(1)
Application.ScreenUpdating = False
For Each Row1 In ws1.UsedRange.Rows
'If rows are blank then skip
If Application.CountA(ws1.Rows(Row1.Row)) > 0 Then
NewStr1 = "Sheet1"
For Each Col1 In ws1.UsedRange.Columns
NewStr1 = NewStr1 & "||" & ws1.Cells(Row1.Row, Col1.Column) ' it's throwing runtime error on this line.
Next
If MyDic.exists(NewStr1) Then
'Colour intra sheet duplicates in sheet 1 as blue
ws1.Rows(Row1.Row).Interior.Color = vbBlue
ws1.Rows(MyDic(NewStr1)).Interior.Color = vbRed
Else
MyDic.Add NewStr1, Row1.Row
End If
End If
Next
Application.ScreenUpdating = True
Set MyDic = Nothing
Set ws1 = Nothing
End Sub
Last edited by abhay_547; Mar 1st, 2018 at 12:30 AM.
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case. Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
Re: highlight duplicate rows include original instance.
Great. It works now. I just need 1 more addition .i.e. to copy red or blue (either one) highlighted cells data including header (don't want to hard code the range, highlighted in bold) in a new sheet and name it as "Filtered out data" and delete all red and blue colored rows from the original worksheet.
Code:
Sheets.Add
ActiveSheet.Name = "Filtered Out Data"
ActiveSheet.Range("$A$1:$BG$3040").AutoFilter Field:=1, Criteria1:=RGB(0, 0 _
, 255), Operator:=xlFilterCellColor
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Filtered Out Data").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("A1").Select
Last edited by abhay_547; Mar 1st, 2018 at 03:27 PM.
Re: highlight duplicate rows include original instance.
as you do not store the rows that match, only change the colour, you would have to loop all the rows again
i would look at storing all the matched rows, to be able to work with them later
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case. Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
Re: highlight duplicate rows include original instance.
Ok. got it. in that case how do i filter for both blue and red rows at one go from base data and also I don't want to hard code the filter range (highlighted in bold). can you help
Code:
Option Explicit
Sub HighDupes()
Dim ws1 As Worksheet
Dim Row1 As Range
Dim Col1 As Range
Dim NewStr1 As String
'Needs reference to Microsoft Scripting Runtime
Dim MyDic As Dictionary
Set MyDic = New Dictionary
Set ws1 = ActiveWorkbook.Sheets(1)
Application.ScreenUpdating = False
For Each Row1 In ws1.UsedRange.Rows
'If rows are blank then skip
If Application.CountA(ws1.Rows(Row1.Row)) > 0 Then
NewStr1 = "Sheet1"
For Each Col1 In ws1.UsedRange.Columns
NewStr1 = NewStr1 & "||" & cstr(ws1.Cells(Row1.Row, Col1.Column))
Next
If MyDic.exists(NewStr1) Then
'Colour intra sheet duplicates in sheet 1 as blue
ws1.Rows(Row1.Row).Interior.Color = vbBlue
ws1.Rows(MyDic(NewStr1)).Interior.Color = vbRed
Else
MyDic.Add NewStr1, Row1.Row
End If
End If
Next
Application.ScreenUpdating = True
Set MyDic = Nothing
Set ws1 = Nothing
Sheets.Add
ActiveSheet.Name = "Filtered Out Data"
Sheets(1).Select
ActiveSheet.Range("$A$1:$BG$3040").AutoFilter Field:=1, Criteria1:=RGB(0, 0 _
, 255), Operator:=xlFilterCellColor
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Filtered Out Data").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Sheets(1).Select
Cells.Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("A1").Select
End Sub
Re: highlight duplicate rows include original instance.
your original macro could have multiple matched rows, that did not all match each other
should they all get to copied (moved) to the same worksheet, or should the different matched rows each be moved to different worksheets?
do you actually need to colour the rows, or just move them?
Last edited by westconn1; Mar 2nd, 2018 at 03:49 AM.
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case. Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
Re: highlight duplicate rows include original instance.
Ok. Color coding is not important, I thought it makes it easy to identify the data using colors. I just need same original set of rows and same duplicate set of rows to be identified first and then move original set of rows to "filtered out data" worksheet and delete the both original set of rows and duplicated set of rows from Sheets (1). Color coding is just to identify the data which needs to be deleted from sheets(1) using the duplicates criteria.
Re: highlight duplicate rows include original instance.
Originally Posted by vbfbryce
Can you zip and attach a "before and after" example? I'm still a little unclear what you want exactly.
There were no attachments in this thread. I have a data in which I have some duplicate rows items (spanning across multiple colums) and I want to identify those duplicate row items along with original set of rows and move the original set of rows to a new worksheet and delete both original and duplicate set of rows. the initial code posted was to identify the duplicate and original set of rows through some color coding .i.e. blue and red.
Re: highlight duplicate rows include original instance.
you can test with this modification to your code, see if it does what you want
Code:
Dim ws1 As Worksheet
Dim Row1 As Range
Dim Col1 As Range
Dim NewStr1 As String
'Needs reference to Microsoft Scripting Runtime
Dim MyDic As Dictionary
Set MyDic = New Dictionary
Set ws1 = ActiveWorkbook.Sheets("sheet2")
Application.ScreenUpdating = False
For Each Row1 In ws1.UsedRange.Rows
'If rows are blank then skip
If Application.CountA(ws1.Rows(Row1.row)) > 0 Then
NewStr1 = "ws1.name"
For Each Col1 In ws1.UsedRange.Columns
NewStr1 = NewStr1 & "||" & ws1.Cells(Row1.row, Col1.Column) ' it's throwing runtime error on this line.
Next
If MyDic.exists(NewStr1) Then
Set rng = MyDic.Item(NewStr1)
Set rng = Union(rng, Cells(Row1.row, 1).Resize(, ws1.UsedRange.Columns.Count))
Set MyDic.Item(NewStr1) = rng
'Colour intra sheet duplicates in sheet 1 as blue
''ws1.Rows(Row1.row).Interior.Color = vbBlue
''ws1.Rows(MyDic(NewStr1)).Interior.Color = vbRed
Else
MyDic.Add NewStr1, ws1.Cells(Row1.row, 1).Resize(, ws1.UsedRange.Columns.Count)
End If
End If
Next
For Each rng In MyDic.Items
x = x + 1
Debug.Print rng.Address
If rng.Areas.Count > 1 Or rng.Rows.Count > 1 Then
Set sht = ws1.Parent.Sheets.Add
rc = 1
sht.Name = "dup" & x
For Each rw In rng.Rows
sht.Cells(rc, 1).Resize(, rw.Columns.Count).Value = rw.Value
rc = rc + 1
Next
rng.Delete xlShiftUp
End If
Next
Application.ScreenUpdating = True
Set MyDic = Nothing
Set ws1 = Nothing
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case. Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
Re: highlight duplicate rows include original instance.
There were no attachments in this thread
we know that, bryce was asking you to attach one, so much easier to work with than trying to create a similar data set
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case. Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
Re: highlight duplicate rows include original instance.
It's working but it moves each original and duplicate set of rows into a separate sheet but I want all the original and duplicate set of rows to be moved into one worksheet and name it as "Filtered Out data". the dup1, dup2 text which is used by you to name the worksheet is useful, can we enter the same text in the last column of "Filtered out data" worksheet instead. e.g. below snapshot.
Re: highlight duplicate rows include original instance.
but I want all the original and duplicate set of rows to be moved into one worksheet and name it as "Filtered Out data"
i an sure by now you should be able to modify the code to achieve that result
can we enter the same text in the last column of "Filtered out data" worksheet
that should also be very easy to do
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case. Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
Re: highlight duplicate rows include original instance.
I tried the below but it shows errors on the lines which are highlighted in bold and blue. instead I can use the combine sheets method post running the entire macro, but I think we don't need to use the combine sheets macro over here, it can be avoided and we can incorporate the logic in the main macro but I am not clear on how it can be achieved. Would appreciate if you can help.
Below is main macro slightly tweaked by me to attempt to copy all duplicate and original set of rows into one sheet .i.e. Filtered out data, but it shows a compile error: variable not defined if we retain option explicit on top and if I remove the option explicit then it shows Object required error on the next line which is highlighted bold and blue:
Code:
Option Explicit
Sub IdentifyDuplicatesandmove()
Dim ws1 As Worksheet
Dim Row1 As Range
Dim Col1 As Range
Dim NewStr1 As String
'Needs reference to Microsoft Scripting Runtime
Dim MyDic As Dictionary
Set MyDic = New Dictionary
Set ws1 = ActiveWorkbook.Sheets("Sheet2")
Application.ScreenUpdating = False
For Each Row1 In ws1.UsedRange.Rows
'If rows are blank then skip
If Application.CountA(ws1.Rows(Row1.row)) > 0 Then
NewStr1 = "ws1.name"
For Each Col1 In ws1.UsedRange.Columns
NewStr1 = NewStr1 & "||" & CStr(ws1.Cells(Row1.row, Col1.Column))
Next
If MyDic.exists(NewStr1) Then
Set rng = MyDic.Item(NewStr1) ' Compile error: variable not defined
Set rng = Union(rng, Cells(Row1.row, 1).Resize(, ws1.UsedRange.Columns.Count))
Set MyDic.Item(NewStr1) = rng
'Colour intra sheet duplicates in sheet 1 as blue
''ws1.Rows(Row1.row).Interior.Color = vbBlue
''ws1.Rows(MyDic(NewStr1)).Interior.Color = vbRed
Else
MyDic.Add NewStr1, ws1.Cells(Row1.row, 1).Resize(, ws1.UsedRange.Columns.Count)
End If
End If
Next
For Each rng In MyDic.Items
x = x + 1
Debug.Print rng.Address
If rng.Areas.Count > 1 Or rng.Rows.Count > 1 Then
Set sht = ws1.Parent.Sheets.Add
rc = 1
sht.Name = "Filtered Out Data"
sht.Cells(rc, 1).Resize(, rw.Columns.Count).Value = rw.Value
rc = rc + 1
rng.Delete xlShiftUp
End If
Next
Application.ScreenUpdating = True
Set MyDic = Nothing
Set ws1 = Nothing
End Sub
below is the combine sheet macro which can be run post running the original macro and it would work, but I believe it would be better if we add the logic in the main macro itself instead of first getting them in separate sheets and then combining.
Code:
Sub combineshts()
Dim i As Integer
Dim xTCount As Variant
Dim xWs As Worksheet
xTCount = 1
Set xWs = ActiveWorkbook.Worksheets.Add(Sheets(1))
xWs.Name = "Filtered Out Data"
Sheets("Sheet2").Range("A1").EntireRow.Copy Destination:=xWs.Range("A1")
For i = 2 To Worksheets.Count
For Each xWs In ThisWorkbook.Worksheets
If xWs.Name <> "Pivot" And xWs.Name <> "Pivot2" And xWs.Name <> "Mapping" Then
Worksheets(i).Range("A1").CurrentRegion.Offset(CInt(xTCount), 0).Copy _
Destination:=xWs.Cells(xWs.UsedRange.Cells(xWs.UsedRange.Count).row + 1, 1)
End If
Next
Next
Application.DisplayAlerts = False
For Each xWs In ActiveWorkbook.Sheets
If Left(xWs.Name, 3) = "dup" Then
xWs.Delete
End If
Next xWs
Application.DisplayAlerts = True
End Sub
Last edited by abhay_547; Mar 4th, 2018 at 12:49 PM.
Re: highlight duplicate rows include original instance.
Code:
If MyDic.exists(NewStr1) Then
Set MyDic.Item(NewStr1) = union(MyDic.Item(NewStr1),Cells(Row1.row, 1).Resize(, ws1.UsedRange.Columns.Count))
Else
MyDic.Add NewStr1, ws1.Cells(Row1.row, 1).Resize(, ws1.UsedRange.Columns.Count)
End If
you can replace the error part with as above
surly you would know by now that variable not defined means to dimension (dim) the variable
Code:
Set sht = ws1.Parent.Sheets.Add
sht.Name = "duplicates"
rc = 1
For Each rng In MyDic.Items
x = x + 1
Debug.Print rng.Address
If rng.Areas.Count > 1 Or rng.Rows.Count > 1 Then
For Each rw In rng.Rows
sht.Cells(rc, 1).Resize(, rw.Columns.Count).Value = rw.Value
sht.offset(,rw.columns.count) = "dup" & x
rc = rc + 1
Next
rng.Delete xlShiftUp
End If
Next
the above code should put all the duplicates into the same sheet, with dup number
you will still need to define all additional variables, up to you to figure out what they are
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case. Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
Re: highlight duplicate rows include original instance.
Ok. I have updated the code by defining variables, but it seems something is going wrong. It shows compile error on the line highlighted in blue. Can you please help.
Code:
Option Explicit
Sub IdentifyDuplicatesandmovenew()
Dim ws1 As Worksheet
Dim Row1 As Range
Dim Col1 As Range
Dim NewStr1 As String
'Needs reference to Microsoft Scripting Runtime
Dim MyDic As Dictionary
Set MyDic = New Dictionary
Set ws1 = ActiveWorkbook.Sheets("Raw Data")
Application.ScreenUpdating = False
For Each Row1 In ws1.UsedRange.Rows
'If rows are blank then skip
If Application.CountA(ws1.Rows(Row1.Row)) > 0 Then
NewStr1 = "ws1.name"
For Each Col1 In ws1.UsedRange.Columns
NewStr1 = NewStr1 & "||" & CStr(ws1.Cells(Row1.Row, Col1.Column))
Next
If MyDic.exists(NewStr1) Then
Set MyDic.Item(NewStr1) = Union(MyDic.Item(NewStr1), Cells(Row1.Row, 1).Resize(, ws1.UsedRange.Columns.Count))
Else
MyDic.Add NewStr1, ws1.Cells(Row1.Row, 1).Resize(, ws1.UsedRange.Columns.Count)
End If
End If
Next
Dim sht As Worksheet
Dim rc As Integer
Dim rng As Range
Dim x As Integer
Dim rw As Range
Set sht = ws1.Parent.Sheets.Add
sht.Name = "duplicates"
rc = 1
For Each rng In MyDic.Items
x = x + 1
Debug.Print rng.Address
If rng.Areas.Count > 1 Or rng.Rows.Count > 1 Then
For Each rw In rng.Rows
sht.Cells(rc, 1).Resize(, rw.Columns.Count).Value = rw.Value
sht.Offset(, rw.Columns.Count) = "dup" & x ' Compile Error: Method or Data Member not found.
rc = rc + 1
Next
rng.Delete xlShiftUp
End If
Next
Application.ScreenUpdating = True
Set MyDic = Nothing
Set ws1 = Nothing
End Sub
Re: highlight duplicate rows include original instance.
i was in a bit of a hurry to finish, so did not test any of the updated code
should have been
Code:
sht.cells(rc,1),Offset(, rw.Columns.Count) = "dup" & x
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case. Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
Re: highlight duplicate rows include original instance.
Now it shows syntax error on the updated line (highlighted in blue)
Code:
Option Explicit
Sub IdentifyDuplicatesandmovenew()
Dim ws1 As Worksheet
Dim Row1 As Range
Dim Col1 As Range
Dim NewStr1 As String
'Needs reference to Microsoft Scripting Runtime
Dim MyDic As Dictionary
Set MyDic = New Dictionary
Set ws1 = ActiveWorkbook.Sheets("Raw Data")
Application.ScreenUpdating = False
For Each Row1 In ws1.UsedRange.Rows
'If rows are blank then skip
If Application.CountA(ws1.Rows(Row1.Row)) > 0 Then
NewStr1 = "ws1.name"
For Each Col1 In ws1.UsedRange.Columns
NewStr1 = NewStr1 & "||" & CStr(ws1.Cells(Row1.Row, Col1.Column))
Next
If MyDic.exists(NewStr1) Then
Set MyDic.Item(NewStr1) = Union(MyDic.Item(NewStr1), Cells(Row1.Row, 1).Resize(, ws1.UsedRange.Columns.Count))
Else
MyDic.Add NewStr1, ws1.Cells(Row1.Row, 1).Resize(, ws1.UsedRange.Columns.Count)
End If
End If
Next
Dim sht As Worksheet
Dim rc As Integer
Dim rng As Range
Dim x As Integer
Dim rw As Range
Set sht = ws1.Parent.Sheets.Add
sht.Name = "duplicates"
rc = 1
For Each rng In MyDic.Items
x = x + 1
Debug.Print rng.Address
If rng.Areas.Count > 1 Or rng.Rows.Count > 1 Then
For Each rw In rng.Rows
sht.Cells(rc, 1).Resize(, rw.Columns.Count).Value = rw.Value
sht.cells(rc,1),Offset(, rw.Columns.Count) = "dup" & x ' Compile Error: syntax error.
rc = rc + 1
Next
rng.Delete xlShiftUp
End If
Next
Application.ScreenUpdating = True
Set MyDic = Nothing
Set ws1 = Nothing
End Sub
Re: highlight duplicate rows include original instance.
oops
should be .offset
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case. Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
Re: highlight duplicate rows include original instance.
Now it shows Run time error '424' Object required on the line highlighted in blue.
Code:
Option Explicit
Sub IdentifyDuplicatesandmovenew()
Dim ws1 As Worksheet
Dim Row1 As Range
Dim Col1 As Range
Dim NewStr1 As String
'Needs reference to Microsoft Scripting Runtime
Dim MyDic As Dictionary
Set MyDic = New Dictionary
Set ws1 = ActiveWorkbook.Sheets("Raw Data")
Application.ScreenUpdating = False
For Each Row1 In ws1.UsedRange.Rows
'If rows are blank then skip
If Application.CountA(ws1.Rows(Row1.Row)) > 0 Then
NewStr1 = "ws1.name"
For Each Col1 In ws1.UsedRange.Columns
NewStr1 = NewStr1 & "||" & CStr(ws1.Cells(Row1.Row, Col1.Column))
Next
If MyDic.exists(NewStr1) Then
Set MyDic.Item(NewStr1) = Union(MyDic.Item(NewStr1), Cells(Row1.Row, 1).Resize(, ws1.UsedRange.Columns.Count))
Else
MyDic.Add NewStr1, ws1.Cells(Row1.Row, 1).Resize(, ws1.UsedRange.Columns.Count)
End If
End If
Next
Dim sht As Worksheet
Dim rc As Integer
Dim rng As Range
Dim x As Integer
Dim rw As Range
Set sht = ws1.Parent.Sheets.Add
sht.Name = "duplicates"
rc = 1
For Each rng In MyDic.Items
x = x + 1
Debug.Print rng.Address
If rng.Areas.Count > 1 Or rng.Rows.Count > 1 Then
For Each rw In rng.Rows
sht.Cells(rc, 1).Resize(, rw.Columns.Count).Value = rw.Value
sht.cells(rc,1).Offset(, rw.Columns.Count) = "dup" & x ' Compile Error: syntax error.
rc = rc + 1
Next
rng.Delete xlShiftUp
End If
Next
Application.ScreenUpdating = True
Set MyDic = Nothing
Set ws1 = Nothing
End Sub
Re: highlight duplicate rows include original instance.
for whatever reason, while rng variable does hold a range when the mydic item is assigned to it, it will only work if rng is of type variant, so dim rng as variant, or just dim rng
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case. Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
Re: [RESOLVED] highlight duplicate rows include original instance.
Just one last thing, it creates the duplicates sheet, even when there are zero duplicates sometimes in the sheet. can we avoid created the duplicates sheet when there are no duplicates and show a msgbox. no duplicates found.
Re: [RESOLVED] highlight duplicate rows include original instance.
Code:
rc = 1
For Each rng In MyDic.Items
x = x + 1
Debug.Print rng.Address
If rng.Areas.Count > 1 Or rng.Rows.Count > 1 Then
if sht is nothing then
Set sht = ws1.Parent.Sheets.Add
sht.Name = "duplicates"
end if
For Each rw In rng.Rows
sht.Cells(rc, 1).Resize(, rw.Columns.Count).Value = rw.Value
sht.cells(rc,1).Offset(, rw.Columns.Count) = "dup" & x ' Compile Error: syntax error.
rc = rc + 1
Next
rng.Delete xlShiftUp
End If
Next
if sht is nothing then msgbox "No Duplicates Found"
try this one
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case. Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete