How to remove unmatched cell values using VBA

[satish78]

Hi Friends,

Looked on similar posts on this forum but did not find suitable solutions to my need.
Here what I am looking to get this done by vba macro.

I have list of data in Sheet1 and sheet2 with values to find in sheet1.
VBA macro to find matched sheet2(ColumnA) data in sheet1 anywhere and remove unmatched cell values from the range D:P
and move matched cell values in respective rows in Sheet1 columnD.

Sample file and Sample Results file attached.
Please take a look.

https://spaces.hightail.com/space/JjGtJaPocB

 

[Peter_SSs]

Give this a try in a copy of your workbook.
If your data is very large this may be slow? If it is slow report back with about how many rows you actually have and confirm that D:P is the limit of columns to deal with.

Sub Remove_Unmatched()
  Dim a As Variant, itm As Variant
  
  With Sheets("Sheet2")
    a = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Value
  End With
  With Sheets("Sheet1").Range("D:P")
    For Each itm In a
      .Replace What:=itm, Replacement:=Replace(itm, "@", "##"), LookAt:=xlWhole, MatchCase:=False
    Next itm
    .Replace What:="*@*", Replacement:=""
    .Replace What:="##", Replacement:="@", LookAt:=xlPart
    On Error Resume Next
    .SpecialCells(xlBlanks).Delete Shift:=xlToLeft
    On Error GoTo 0
  End With
End Sub

 

[satish78]

its fast on this small data.

Thanks Peter.

Give this a try in a copy of your workbook.
If your data is very large this may be slow? If it is slow report back with about how many rows you actually have and confirm that D:P is the limit of columns to deal with.

Sub Remove_Unmatched()
  Dim a As Variant, itm As Variant
  
  With Sheets("Sheet2")
    a = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Value
  End With
  With Sheets("Sheet1").Range("D:P")
    For Each itm In a
      .Replace What:=itm, Replacement:=Replace(itm, "@", "##"), LookAt:=xlWhole, MatchCase:=False
    Next itm
    .Replace What:="*@*", Replacement:=""
    .Replace What:="##", Replacement:="@", LookAt:=xlPart
    On Error Resume Next
    .SpecialCells(xlBlanks).Delete Shift:=xlToLeft
    On Error GoTo 0
  End With
End Sub

 

[Peter_SSs]

its fast on this small data.

Thanks Peter.

You're welcome. Thanks for the follow-up.