Search for matches and delete in multiple columns.

[Bradzo]

Hi all,

Looking to refine a macro that I have been using for some time now and don't know how to make the required changes and appreciate the assistance.

The current macro looks in Sh1 as searchsheet Column B for the manifest numbers and deletes any duplicates from Sh2 targetsheet prior to another macro copying them over.

What I'm trying to achieve is for the macro the search for duplicates in both column B & D as column B may have the same manifest number, but column D will contain a different item number and will need copying across.

I only want to delete the row if Columns B&D are the same in both sheets.

I have tried several times to make this work but can't seem to manage it, help would be greatly appreciated.

Thanks Brad

Sub CleanDupes()
Dim targetRange As Range, searchRange As Range
Dim targetArray
Dim x As Long
Application.ScreenUpdating = False
Dim TargetSheetName As String: TargetSheetName = ("Sh2")
Dim TargetSheetColumn As String: TargetSheetColumn = "B"
Dim SearchSheetName As String: SearchSheetName = ("Sh1")
Dim SearchSheetColumn As String: SearchSheetColumn = "B"

'Load target array
With Sheets(TargetSheetName)
Set targetRange = .Range(.Range(TargetSheetColumn & "1"), _
.Range(TargetSheetColumn & Rows.Count).End(xlUp))
targetArray = targetRange
End With
'Get Search Range
With Sheets(SearchSheetName)
Set searchRange = .Range(.Range(SearchSheetColumn & "1"), _
.Range(SearchSheetColumn & Rows.Count).End(xlUp))
End With
If IsArray(targetArray) Then
For x = UBound(targetArray) To 1 Step -1
If Application.WorksheetFunction.CountIf(searchRange, _
targetArray(x, 1)) Then
targetRange.Cells(x).EntireRow.Delete
End If
Next
Else
If Application.WorksheetFunction.CountIf(searchRange, targetArray) Then
targetRange.EntireRow.Delete
End If
End If
Application.ScreenUpdating = True
Call Transfer
End Sub

 

[Herakles]

Hi all,

Looking to refine a macro that I have been using for some time now and don't know how to make the required changes and appreciate the assistance.

The current macro looks in Sh1 as searchsheet Column B for the manifest numbers and deletes any duplicates from Sh2 targetsheet prior to another macro copying them over.

What I'm trying to achieve is for the macro the search for duplicates in both column B & D as column B may have the same manifest number, but column D will contain a different item number and will need copying across.

I only want to delete the row if Columns B&D are the same in both sheets.

I have tried several times to make this work but can't seem to manage it, help would be greatly appreciated.

Thanks Brad

Sub CleanDupes()
Dim targetRange As Range, searchRange As Range
Dim targetArray
Dim x As Long
Application.ScreenUpdating = False
Dim TargetSheetName As String: TargetSheetName = ("Sh2")
Dim TargetSheetColumn As String: TargetSheetColumn = "B"
Dim SearchSheetName As String: SearchSheetName = ("Sh1")
Dim SearchSheetColumn As String: SearchSheetColumn = "B"

'Load target array
With Sheets(TargetSheetName)
Set targetRange = .Range(.Range(TargetSheetColumn & "1"), _
.Range(TargetSheetColumn & Rows.Count).End(xlUp))
targetArray = targetRange
End With
'Get Search Range
With Sheets(SearchSheetName)
Set searchRange = .Range(.Range(SearchSheetColumn & "1"), _
.Range(SearchSheetColumn & Rows.Count).End(xlUp))
End With
If IsArray(targetArray) Then
For x = UBound(targetArray) To 1 Step -1
If Application.WorksheetFunction.CountIf(searchRange, _
targetArray(x, 1)) Then
targetRange.Cells(x).EntireRow.Delete
End If
Next
Else
If Application.WorksheetFunction.CountIf(searchRange, targetArray) Then
targetRange.EntireRow.Delete
End If
End If
Application.ScreenUpdating = True
Call Transfer
End Sub

MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.

 

[DanteAmor]

Try this:

Sub CleanDupes()
  Dim targetRange As Range, searchRange As Range, searchRange2 As Range
  Dim targetArray
  Dim x As Long, lr As Long
  
  Dim TargetSheetName As String: TargetSheetName = ("Sh2")
  Dim TargetSheetColumn As String: TargetSheetColumn = "B"
  Dim TargetSheetColumn2 As String: TargetSheetColumn2 = "D"
  Dim SearchSheetName As String: SearchSheetName = ("Sh1")
  Dim SearchSheetColumn As String: SearchSheetColumn = "B"
  Dim SearchSheetColumn2 As String: SearchSheetColumn2 = "D"
  
  Application.ScreenUpdating = False
  
  'Load target array
  With Sheets(TargetSheetName)
    lr = .Range(TargetSheetColumn & Rows.Count).End(xlUp).Row
    Set targetRange = .Range(.Range(TargetSheetColumn & "1"), _
      .Range(TargetSheetColumn2 & lr))
    targetArray = targetRange.Value
  End With
  
  'Get Search Range
  With Sheets(SearchSheetName)
    lr = .Range(SearchSheetColumn & Rows.Count).End(xlUp).Row
    Set searchRange = .Range(.Range(SearchSheetColumn & "1"), _
      .Range(SearchSheetColumn & lr))
    Set searchRange2 = .Range(.Range(SearchSheetColumn2 & "1"), _
      .Range(SearchSheetColumn2 & lr))
  End With
  
  If IsArray(targetArray) Then
    For x = UBound(targetArray) To 1 Step -1
      If Application.WorksheetFunction.CountIfs(searchRange, _
        targetArray(x, 1), searchRange2, targetArray(x, 3)) Then
        targetRange.Cells(x).EntireRow.Delete
      End If
    Next
  Else
    If Application.WorksheetFunction.CountIfs(searchRange, _
        targetArray(x, 1), searchRange2, targetArray(x, 3)) Then
      targetRange.EntireRow.Delete
    End If
  End If
  Application.ScreenUpdating = True
  Call Transfer
End Sub

I only modified your macro, but if you need something faster then it will be necessary to create another macro with another approach.

 

[Bradzo]

Try this:

Sub CleanDupes()
  Dim targetRange As Range, searchRange As Range, searchRange2 As Range
  Dim targetArray
  Dim x As Long, lr As Long
 
  Dim TargetSheetName As String: TargetSheetName = ("Sh2")
  Dim TargetSheetColumn As String: TargetSheetColumn = "B"
  Dim TargetSheetColumn2 As String: TargetSheetColumn2 = "D"
  Dim SearchSheetName As String: SearchSheetName = ("Sh1")
  Dim SearchSheetColumn As String: SearchSheetColumn = "B"
  Dim SearchSheetColumn2 As String: SearchSheetColumn2 = "D"
 
  Application.ScreenUpdating = False
 
  'Load target array
  With Sheets(TargetSheetName)
    lr = .Range(TargetSheetColumn & Rows.Count).End(xlUp).Row
    Set targetRange = .Range(.Range(TargetSheetColumn & "1"), _
      .Range(TargetSheetColumn2 & lr))
    targetArray = targetRange.Value
  End With
 
  'Get Search Range
  With Sheets(SearchSheetName)
    lr = .Range(SearchSheetColumn & Rows.Count).End(xlUp).Row
    Set searchRange = .Range(.Range(SearchSheetColumn & "1"), _
      .Range(SearchSheetColumn & lr))
    Set searchRange2 = .Range(.Range(SearchSheetColumn2 & "1"), _
      .Range(SearchSheetColumn2 & lr))
  End With
 
  If IsArray(targetArray) Then
    For x = UBound(targetArray) To 1 Step -1
      If Application.WorksheetFunction.CountIfs(searchRange, _
        targetArray(x, 1), searchRange2, targetArray(x, 3)) Then
        targetRange.Cells(x).EntireRow.Delete
      End If
    Next
  Else
    If Application.WorksheetFunction.CountIfs(searchRange, _
        targetArray(x, 1), searchRange2, targetArray(x, 3)) Then
      targetRange.EntireRow.Delete
    End If
  End If
  Application.ScreenUpdating = True
  Call Transfer
End Sub

I only modified your macro, but if you need something faster then it will be necessary to create another macro with another approach.

Hi Dante, I have inserted the changes and coming up with a Runtime 1004 error, when the scrips attempts to delete the row. I have included a screen shot. Thanks Brad

 

[Bradzo]

Hi Dante, I have inserted the changes and coming up with a Runtime 1004 error, when the scrips attempts to delete the row. I have included a screen shot. Thanks Brad

Sorted, changed targetRange.Cells(x).EntireRow.Delete to targetRange.rows(x).EntireRow.Delete and this has resolved the issue. Thanks again, Brad