Copy rows that match values in a column of names

**lunatyck** · 08-09-2012, 03:42 PM

Hi folks.

I did my best to search the forums to find an answer that would fulfill what I need done, but I had no luck. It seems that there are hundreds of copy rows requests, but all seem to be unique in their own ways.

Essentially I have a column of company names in one tab (Tab A), and then a huge list of company names with data in another tab (Tab B). Since I can't use vlookup to copy over whole rows (Please note that I want the whole row and not only the columns listed in the sample data.. i have deleted some columns for privacy reasons), I am needing a copy row function that would essentially copy over any lines from Tab B to a new spreadsheet/tab names results or something similar, where a company name found in tab A matches in tab B. The reason I need this macro is because i have over 40000 lines in Tab B and roughly 300 lines in tab A. If I had to filter by each name (~300) , copy and paste to a new spreadsheet.. this would take hours.

I have attached sample data below. Notice that I have included a supplier name and unique number. You can alternatively match against the number since it leaves less room for error since sometimes leading/trailing spaces, etc. call for mismatches and missed data.

I whole heartily appreciate your help and expertise. This is a wonderful community and has helped me a lot before! In short, you guys are all geniuses!

Thanks again.
-Konrad

**lunatyck** · 08-09-2012, 03:57 PM

After thinking about this all morning, I'm assuming this would be a simple if loop statement saying

"
int n=2;
if Tab A:Bn == Tab B:B#, copy row to Tab C. Else n++;

"

I know thats not the right syntax or structure but I'm guessing that is what the final code will basically do.

**lunatyck** · 08-10-2012, 10:03 AM

Bump to the top!

**lunatyck** · 08-10-2012, 04:39 PM

Here is an update with some code that user CatDaddy from vbaexpress forums. Although the code looks good, I keep getting an error that just says 400 in excel 2007. Can anyone look this through to see why its throwing an error?

Thanks and happy friday!

Sub alex() 
Application.ScreenUpdating = False 
 
Dim cell, cell2 As Range 
Dim lr, lr2, r As Long 
 
Sheets.Add After:=Sheets(Sheets.Count) 
ActiveSheet.Name = "result" 
Sheets(1).Activate 
lr = Range("A" & Rows.Count).End(xlUp).row 
 
For Each cell In Range("A1:A" & lr) 
    ActiveWorkbook.Sheets(2).Activate 
    lr2 = Range("A" & Rows.Count).End(xlUp).row 
    For Each cell2 In Range("A1:A" & lr2) 
    If cell2.Text = cell.Text Then 
        cell2.EntireRow.Copy Destination:=Sheets("result").Range("A" & r) 
        r = r + 1 
    End If 
Next cell2 
Next cell 
Application.ScreenUpdating = True 
 
End Sub

**lunatyck** · 08-13-2012, 11:22 AM

Marking this thread as solved (even though the solution came from another forum) in case someone else can use the macro for themselves down the road:

Code credit and courtesy to 'CatDaddy' from VBAexpress forums:

Sub alex() 
    Application.ScreenUpdating = False 
     
    Dim cell, cell2 As Range 
    Dim lr, lr2, r As Long 
     
    Sheets.Add After:=Sheets(Sheets.Count) 
    ActiveSheet.Name = "result" 
    Sheets(1).Activate 
    lr = Range("A" & Rows.Count).End(xlUp).Row 
    r = 1 
     
    For Each cell In Range("A1:A" & lr) 
        ActiveWorkbook.Sheets(2).Activate 
        lr2 = Range("A" & Rows.Count).End(xlUp).Row 
        For Each cell2 In Range("A1:A" & lr2) 
            If cell2.Text = cell.Text Then 
                cell2.EntireRow.Copy Destination:=Sheets("result").Range("A" & r) 
                r = r + 1 
            End If 
        Next cell2 
    Next cell 
    Application.ScreenUpdating = True 
     
End Sub

---------- Post added at 10:22 AM ---------- Previous post was at 10:18 AM ----------

Marking this thread as solved (even though the solution came from another forum) in case someone else can use the macro for themselves down the road:

Code credit and courtesy to 'CatDaddy' from VBAexpress forums:

Sub alex() 
    Application.ScreenUpdating = False 
     
    Dim cell, cell2 As Range 
    Dim lr, lr2, r As Long 
     
    Sheets.Add After:=Sheets(Sheets.Count) 
    ActiveSheet.Name = "result" 
    Sheets(1).Activate 
    lr = Range("A" & Rows.Count).End(xlUp).Row 
    r = 1 
     
    For Each cell In Range("A1:A" & lr) 
        ActiveWorkbook.Sheets(2).Activate 
        lr2 = Range("A" & Rows.Count).End(xlUp).Row 
        For Each cell2 In Range("A1:A" & lr2) 
            If cell2.Text = cell.Text Then 
                cell2.EntireRow.Copy Destination:=Sheets("result").Range("A" & r) 
                r = r + 1 
            End If 
        Next cell2 
    Next cell 
    Application.ScreenUpdating = True 
     
End Sub