VBA to copy row to another worksheet if cell value is found in a list

[mkseto]

I have 3 worksheets in a workbook:
"Source" - contains a 2-column list, first column are numbers (integer) and are all unique (i.e. no 2 rows with the same value), and 2nd column is a name (irrelevant in this exercise)
"Data" - contains a table with multiple columns, first column is a number (also integer but not unique within the column). Other columns are irrelevant in this exercise)
"Results" - blank

For each row in the "Data" sheet, I need to check the value in the 1st column against the first column in the "Source" sheet, if value (i.e. "Data") is found in the "Source" sheet, I need to copy the whole row from the "Data" sheet to the "Results" sheet. In other words, at the end of this exercise, the "Results" sheet will contain all rows from the "Data" sheet where the value in the 1st column is found in the 1st column of "Source".

I perform this on a regular basis and both the "Source" and "Data" sheets always change in size (i.e. now of rows). I would love to get a macro to do this so that I wouldn't need to repeat the tedious exercise, but my knowledge with VBA is extremely limited. Help would be much appreciated.

 

[Trebor76]

Hi mkseto,

Try this:

Option Explicit
Sub Macro1()

    Dim wsSrc As Worksheet, wsData As Worksheet, wsResult As Worksheet
    Dim i As Long, j As Long
    
    Application.ScreenUpdating = False
    
    Set wsSrc = ThisWorkbook.Sheets("Source")
    Set wsData = ThisWorkbook.Sheets("Data")
    Set wsResult = ThisWorkbook.Sheets("Result")
    
    On Error Resume Next
        j = wsResult.Range("A:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        j = IIf(j = 0, 1, j + 1)
    On Error GoTo 0
    
    For i = 1 To wsData.Cells(Rows.Count, "A").End(xlUp).Row
        If Application.WorksheetFunction.CountIf(wsSrc.Range("A:A"), CLng(wsData.Range("A" & i))) > 0 Then
            wsData.Rows(i).Copy Destination:=wsResult.Rows(j)
            Application.CutCopyMode = False
            j = j + 1
        End If
    Next i
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[mkseto]

Works perfectly, thanks a million!!!!

 

[Trebor76]

Thanks for letting us know and you're welcome

 

[rdas]

Thanks for letting us know and you're welcome

Hi Can you just help me on instead of copy the records in other sheet how to delete those rows which matches.

 

[Trebor76]

Hi Can you just help me on instead of copy the records in other sheet how to delete those rows which matches.

Do you mean delete any duplicates from say Col. A?

 

[rdas]

Do you mean delete any duplicates from say Col. A?

yes. exactly so. thank you very much.

 

[Trebor76]

Try this (initially on a copy of your data as the results cannot be undone if they're not as expected):

Option Explicit
Sub Macro1()

    Dim ws As Worksheet
    
    Application.ScreenUpdating = False
      
    Set ws = ThisWorkbook.Sheets("Sheet1") '<-Sheet name with duplicates in Col. A to be deleted. Change to suit.
    On Error Resume Next
        ws.ShowAllData
    On Error GoTo 0
    ws.Range("A1:A" & ws.Cells(Rows.Count, "A").End(xlUp).Row).RemoveDuplicates Columns:=Array(1), Header:=xlYes
    
    Application.ScreenUpdating = True

End Sub

 

[rdas]

Try this (initially on a copy of your data as the results cannot be undone if they're not as expected):

Option Explicit
Sub Macro1()

    Dim ws As Worksheet
   
    Application.ScreenUpdating = False
     
    Set ws = ThisWorkbook.Sheets("Sheet1") '<-Sheet name with duplicates in Col. A to be deleted. Change to suit.
    On Error Resume Next
        ws.ShowAllData
    On Error GoTo 0
    ws.Range("A1:A" & ws.Cells(Rows.Count, "A").End(xlUp).Row).RemoveDuplicates Columns:=Array(1), Header:=xlYes
   
    Application.ScreenUpdating = True

End Sub

Sorry if I have created any confusion.
I am describing my requirement in detail:

In the attachment the source is the source sheet which will be referred to delete the records from Data sheet. in the data sheet col B which can have the blank value as well as ids. now if the source sheet's col A's value matches with the Data sheet's col B value then those will be removed, but it will keep the rows which has the blank ids in the data sheet.

 

[Trebor76]

Try this:

Option Explicit
Sub Macro1()

    Dim lngLastRow As Long, lngArrayIndex As Long
    Dim rngMyCell As Range
    Dim strIDs() As String
    
    Application.ScreenUpdating = False
    
    lngLastRow = Sheets("Source").Cells(Rows.Count, "A").End(xlUp).Row
    For Each rngMyCell In Sheets("Source").Range("A2:A" & lngLastRow)
        If Len(rngMyCell) > 0 Then
            lngArrayIndex = lngArrayIndex + 1
            ReDim Preserve strIDs(1 To lngArrayIndex)
            strIDs(lngArrayIndex) = rngMyCell
        End If
    Next rngMyCell
    
    On Error Resume Next
        Sheets("Data").ShowAllData
    On Error GoTo 0
    lngLastRow = Sheets("Data").Cells(Rows.Count, "B").End(xlUp).Row
    With Sheets("Data").Range("A1:C" & lngLastRow)
        .AutoFilter Field:=2, Criteria1:=Array(strIDs), Operator:=xlFilterValues
        .Offset(1).EntireRow.Delete
        .AutoFilter
    End With
    
    Application.ScreenUpdating = True

End Sub