Macro - delete same data on other worksheets

September 28, 2011 at 04:18:48
Specs: Windows XP
Hi,

I found a code by Humar and have amended it to sort my workbook, but I cant seem to extend the below code to loop through and look at about 10 worksheets for duplicates.

When I add another "Or wsDest.Name" row, the following error comes up: Compile error, Syntax error.

Can anyone help me please?

'now delete it from any other destination worksheet
'loop through all worksheets
'test if it is one of the four named destination sheets
'but not the one we just copied it to
For Each wsDest In ActiveWorkbook.Worksheets()
If (wsDest.Name = "in_progress" _
Or wsDest.Name = "completed" _
Or wsDest.Name = "pending" _
Or wsDest.Name = "overdue") _
And wsDest.Name <> rngDest.Worksheet.Name Then
'find matching ID - work from end of used range
'just in case there is a duplicate entry
For n = wsDest.UsedRange.Rows.Count To 2 Step -1
'find matching Task
If wsDest.Range("A" & CStr(n)).Text = _
rngSrc.Offset(0, -1).Text Then
'match found, so delete row
wsDest.Range("A" & CStr(n)).EntireRow.Delete
End If
Next n
End If
Next wsDest


See More: Macro - delete same data on other worksheets

Report •

#1
September 29, 2011 at 01:47:36
would be helpful to see the rest of the code.

Report •

#2
September 29, 2011 at 06:00:59
Hi,

Thanks for your reply.

Please see as below:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngSrc As Range
Dim rngDest As Range
Dim wsDest As Worksheet
Dim n As Double

On Error GoTo ErrHnd

'disable events - so that changes made by this code
'do not re-trigger it
Application.EnableEvents = False

'test if the changed cell is in columns B to G
'must action changes in associated data, not just status col. B
If Target.Column > 1 And Target.Column < 16 Then
'set rngSrc to Column B (status) on changed row
Set rngSrc = ActiveSheet.Range("B" & CStr(Target.Row))
'actions based on word entered in column B
Select Case rngSrc.Text
Case "Active"
'find next empty row on the Active sheet
Set rngDest = Worksheets("Active") _
.Range("A" & CStr(Application.Rows.Count)) _
.End(xlUp).Offset(1, 0)
'Set rngDest = rngDest.Offset(1, 0).Offset(1, 0)
Case "Deactive"
'find next empty row on the Deactive sheet
Set rngDest = Worksheets("Deactive") _
.Range("A" & CStr(Application.Rows.Count)) _
.End(xlUp).Offset(1, 0)
Case "Prospective"
'find next empty row on the Prospective sheet
Set rngDest = Worksheets("Prospective") _
.Range("A" & CStr(Application.Rows.Count)) _
.End(xlUp).Offset(1, 0)
Case Else
'no match - so error out
GoTo ErrHnd
End Select

'move the data to the required worksheet
'copy columns A to O - adjust as appropriate
rngSrc.Offset(0, -1).Resize(1, 16).Copy _
Destination:=rngDest

'now delete it from any other destination worksheet
'loop through all worksheets
'test if it is one of the four named destination sheets
'but not the one we just copied it to
For Each wsDest In ActiveWorkbook.Worksheets()
If (wsDest.Name = "in_progress" _
Or wsDest.Name = "Active" _
Or wsDest.Name = "Deactive" _
Or wsDest.Name = "Prospective") _
And wsDest.Name <> rngDest.Worksheet.Name Then
'find matching ID - work from end of used range
'just in case there is a duplicate entry
For n = wsDest.UsedRange.Rows.Count To 2 Step -1
'find matching Task
If wsDest.Range("A" & CStr(n)).Text = _
rngSrc.Offset(0, -1).Text Then
'match found, so delete row
wsDest.Range("A" & CStr(n)).EntireRow.Delete
End If
Next n
End If
Next wsDest

'now test the worksheet we just copied to - for duplicates
'start at row above the one we copied to
With rngDest.Worksheet
For n = rngDest.Row - 1 To 2 Step -1
If .Range("A" & CStr(n)).Text = _
rngSrc.Offset(0, -1).Text Then
'delete row
.Range("A" & CStr(n)).EntireRow.Delete
End If
Next n
End With
End If

'test if the changed cell is in columns B to G
'must action changes in associated data, not just status col. B
If Target.Column > 2 And Target.Column < 16 Then
'set rngSrc to Column B (status) on changed row
Set rngSrc = ActiveSheet.Range("C" & CStr(Target.Row))
'actions based on word entered in column B
Select Case rngSrc.Text
Case "Public"
'find next empty row on the Public sheet
Set rngDest = Worksheets("Public") _
.Range("A" & CStr(Application.Rows.Count)) _
.End(xlUp).Offset(1, 0)
'Set rngDest = rngDest.Offset(1, 0).Offset(1, 0)
Case "Aviation"
'find next empty row on the Aviation sheet
Set rngDest = Worksheets("Aviation") _
.Range("A" & CStr(Application.Rows.Count)) _
.End(xlUp).Offset(1, 0)
Case "Tier One"
'find next empty row on the Tier One sheet
Set rngDest = Worksheets("Tier One") _
.Range("A" & CStr(Application.Rows.Count)) _
.End(xlUp).Offset(1, 0)
Case "Finance"
'find next empty row on the Finance sheet
Set rngDest = Worksheets("Finance") _
.Range("A" & CStr(Application.Rows.Count)) _
.End(xlUp).Offset(1, 0)
Case "Print"
'find next empty row on the Print sheet
Set rngDest = Worksheets("Print") _
.Range("A" & CStr(Application.Rows.Count)) _
.End(xlUp).Offset(1, 0)
Case "Direct"
'find next empty row on the Direct sheet
Set rngDest = Worksheets("Direct") _
.Range("A" & CStr(Application.Rows.Count)) _
.End(xlUp).Offset(1, 0)
Case "Other"
'find next empty row on the Other sheet
Set rngDest = Worksheets("Other") _
.Range("A" & CStr(Application.Rows.Count)) _
.End(xlUp).Offset(1, 0)
Case "Supplier"
'find next empty row on the Supplier sheet
Set rngDest = Worksheets("Supplier") _
.Range("A" & CStr(Application.Rows.Count)) _
.End(xlUp).Offset(1, 0)
Case "Services"
'find next empty row on the Services sheet
Set rngDest = Worksheets("Services") _
.Range("A" & CStr(Application.Rows.Count)) _
.End(xlUp).Offset(1, 0)
Case "Van Hire"
'find next empty row on the Van Hire sheet
Set rngDest = Worksheets("Van Hire") _
.Range("A" & CStr(Application.Rows.Count)) _
.End(xlUp).Offset(1, 0)
Case Else
'no match - so error out
GoTo ErrHnd
End Select

'move the data to the required worksheet
'copy columns A to O - adjust as appropriate
rngSrc.Offset(0, -1).Resize(1, 16).Copy _
Destination:=rngDest

'now delete it from any other destination worksheet
'loop through all worksheets
'test if it is one of the four named destination sheets
'but not the one we just copied it to
For Each wsDest In ActiveWorkbook.Worksheets()
If (wsDest.Name = "in_progress" _
Or wsDest.Name = "Public" _
Or wsDest.Name = "Aviation" _
Or wsDest.Name = "overdue") _
And wsDest.Name <> rngDest.Worksheet.Name Then
'find matching ID - work from end of used range
'just in case there is a duplicate entry
For n = wsDest.UsedRange.Rows.Count To 2 Step -1
'find matching Task
If wsDest.Range("A" & CStr(n)).Text = _
rngSrc.Offset(0, -1).Text Then
'match found, so delete row
wsDest.Range("A" & CStr(n)).EntireRow.Delete
End If
Next n
End If
Next wsDest

'now test the worksheet we just copied to - for duplicates
'start at row above the one we copied to
With rngDest.Worksheet
For n = rngDest.Row - 1 To 2 Step -1
If .Range("A" & CStr(n)).Text = _
rngSrc.Offset(0, -1).Text Then
'delete row
.Range("A" & CStr(n)).EntireRow.Delete
End If
Next n
End With
End If
're-enable events
Application.EnableEvents = True
Exit Sub

'error handler
ErrHnd:
Err.Clear

Thank you for your help in adavnce.


Report •
Related Solutions


Ask Question