Solved: Macro request: Copy rows that match values in a column of names

[lunatyck]

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 that match a company name found in tab A. 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 thank you in advance!!

Regards.
-Konrad

[CatDaddy]

Sub alex()
Application.ScreenUpdating = False
Dim cell, cell2 As Range
Dim lr, lr2, r As Long
Dim str As String
ActiveWorkbook.Sheets(1).Activate
lr = Range("A" & Rows.Count).End(xlUp).Row
For Each cell In Range("A1:A" & lr)
str = cell.Text
r = 1

Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = str

ActiveWorkbook.Sheets(2).Activate
lr2 = Range("A" & Rows.Count).End(xlUp).Row

For Each cell2 In Range("A1:A" & lr2)
If cell2.Text = str Then
cell2.EntireRow.Copy Destination:=Sheets(str).Range("A" & r)
r = r + 1
End If
Next cell2
Next cell

Application.ScreenUpdating = True

End Sub

[lunatyck]

Sub alex()
Application.ScreenUpdating = False
Dim cell, cell2 As Range
Dim lr, lr2, r As Long
Dim str As String
ActiveWorkbook.Sheets(1).Activate
lr = Range("A" & Rows.Count).End(xlUp).Row
For Each cell In Range("A1:A" & lr)
str = cell.Text
r = 1

Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = str

ActiveWorkbook.Sheets(2).Activate
lr2 = Range("A" & Rows.Count).End(xlUp).Row

For Each cell2 In Range("A1:A" & lr2)
If cell2.Text = str Then
cell2.EntireRow.Copy Destination:=Sheets(str).Range("A" & r)
r = r + 1
End If
Next cell2
Next cell

Application.ScreenUpdating = True

End Sub

Thank you for the code! For the most part, the code is working. However, I noticed that all the results for each supplier name creates a new tab. Is there any way for all the lines to come up in the 3rd tab and not separated across hundreds of tabs?

[CatDaddy]

I thought your goal was to separate out all the information by company, what exactly are you trying to accomplish?

[lunatyck]

Let me try to explain it again. If you refer to my sample document, tab A has a list of only supplier names and supplier numbers. Tab B is a much larger list. It has supplier names, numbers, cities etc. If you notice in Tab B there are suppliers that have multiple locations. Your code did exactly what I needed by pulling all the lines from Tab B if the supplier is found in Tab A. However, you divided the results across individual tabs by supplier name.

I don't need them divided into different tabs, I just need a Tab C where all the lines would be copied over to.

I looked through the code (I am no expert but I studied IT in school) and noticed the code


Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = str


I think this is the line that is creating the new tabs for each supplier. I do not need this. Instead the code should add just one sheet named results or something similar, and then have the code paste to it:



cell2.EntireRow.Copy Destination:=Sheets("results").Range("A" & r)


instead of


cell2.EntireRow.Copy Destination:=Sheets(str).Range("A" & r)


Once again I thank you very much for helping me out here.

[CatDaddy]

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]

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

I get an error that just says 400 :/ It doesn't seem to work with my sample data in Excel 2007. Is it working for you?

[CatDaddy]

forgot to initialize r to 1

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

[lunatyck]

Seems to be working! Thank you very much :D I am not sure if I am able to give a +rep or anything similar on this forum.. I can't figure it out. Please let me know how I can do that if that feature is available!

[CatDaddy]

just mark the thread solved in thread tools at the top of the page