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

mkseto

New Member
Joined
Aug 14, 2018
Messages
14
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.
 

Attachments

  • 1.gif
    1.gif
    4.2 KB · Views: 8
  • 2.gif
    2.gif
    9 KB · Views: 8
  • 3.gif
    3.gif
    7.8 KB · Views: 8

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.

Trebor76

Well-known Member
Joined
Jul 23, 2007
Messages
4,823
Hi mkseto,

Try this:

VBA Code:
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
 
Solution

rdas

New Member
Joined
Nov 23, 2021
Messages
3
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Thanks for letting us know and you're welcome :cool:
Hi Can you just help me on instead of copy the records in other sheet how to delete those rows which matches.
 

Trebor76

Well-known Member
Joined
Jul 23, 2007
Messages
4,823
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?
 

Trebor76

Well-known Member
Joined
Jul 23, 2007
Messages
4,823
Try this (initially on a copy of your data as the results cannot be undone if they're not as expected):

VBA Code:
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

New Member
Joined
Nov 23, 2021
Messages
3
Office Version
  1. 365
Platform
  1. Windows
Try this (initially on a copy of your data as the results cannot be undone if they're not as expected):

VBA Code:
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.
 

Attachments

  • Data.JPG
    Data.JPG
    40.4 KB · Views: 2
  • Source.JPG
    Source.JPG
    31.2 KB · Views: 2

Trebor76

Well-known Member
Joined
Jul 23, 2007
Messages
4,823
Try this:

VBA Code:
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
 

Forum statistics

Threads
1,147,735
Messages
5,742,866
Members
423,760
Latest member
photogfrog

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top