Copy Rows based on cell value to match with tab name

[Apple08]

Hi All

I need to copy the row data from "Sheet 8" to "Sheet 1", "Sheet 2", "Sheet 3", "Sheet 4" and "Sheet 5" based on the column A cell value of "Sheet 8". If the cell value is matched with the tab name, e.g. Sheet 1, then the whole row of content will be copied to the worksheet "Sheet 1" from row 2 as there is a header row for all worksheets. The number of rows in "Sheet 8" is unknown.

I wonder is anyone able to help. Many thanks.

 

[rpaulson]

try this

Sub Do_it()

Dim rs As Worksheet
Set rs = Worksheets("Sheet8")

For r = 1 To rs.Range("A" & Rows.Count).End(xlUp).Row
wsName = rs.Cells(r, "A")

If WorksheetFunction.IsErr(Evaluate("'" & wsName & "'!A1")) = "False" Then 'worksheet exists write data
    wr = Worksheets(wsName).Range("A" & Rows.Count).End(xlUp).Row + 1
    rs.Rows(r).Copy Destination:=Worksheets(wsName).Range("A" & wr)
End If

Next r

MsgBox "Done"

End Sub

hth,
Ross

 

[Apple08]

Many thanks Ross, however the macro takes too long to run, it took more than 15 minutes therefore I have to end the task.

I wonder instead of matching the tab names as it might go through all of the tabs, if cells A matches with specific text such as "Red", "Amber", "Green", "Unknow", "On Hold", then paste "Red" into "Sheet 1", "Amber" into "Sheet 2" and so on to "Sheet 5". Does it help to improve the speed? Many thanks.

 

[My Aswer Is This]

If I understand your question correctly.
In column A of Sheet named "Sheet8" if "Alpha" is found in column "A" ignore this row
but if "Sheet6" is found then copy this row to sheet name "Sheet6"

I can see how this could be tasking to evaluate every value in column A to see if the value is a sheet name.
Especially if you have 5,00 rows in column A to evaluate.

 

[Apple08]

Yes your understanding is absolutely correct. However my tab names are also named as "Red", "Amber" and so on with other tabs. Therefore, I just think rather than to have the column A to match with the tab name, is it easier to match with the names "Red" and so on?

 

[My Aswer Is This]

Yes if you had sheet names like:
"Alpha"
"Bravo"
"Charlie"
"Delta"
It would be easier for me at least.
What other values might we find in column A?
And how many rows do we have in column A with values?
Is it like less then 100 more then 500 or greater then 5,000


And lets call the sheet with all the sheet names in column A "Master"

I always like using sheet names like "Master" not "Sheet8"

Some times people mean Sheet(8) meaning which is the 8th sheet when they may mean sheet named "Sheet8"

And I assuming all the sheets already exist

Give me the sheet names we need to search for.

And what version of Excel are you using?
Are you using a "Apple" computer?

 

[Apple08]

Many thanks for your help. The master sheet is "SUP Tracker" (which is sheet8), usually there are over 6000 rows in this sheet and column A includes: STEM, FASS, WELS, PVC-S and FBL, then no more other categories. There are tabs for STEM, FASS, WELS, PVC-S and WELS and other three to four tabs. I want to paste in those rows with STEM in SUP Tracker column A into the tab STEM from the 2nd row as there is a header row and the same for other tabs.

Please let me know if this is not clear.

 

[My Aswer Is This]

So I assume there is no sheet named:
FBL
You did not say you have a sheet named FBL

And you did not say what version of Excel your using and I asked are you using a Apple Computer?

 

[Apple08]

Good spot! The tab should be FBL as I have put WELS twice. I am currently using Excel 2016 and NOT using a Apple Computer.

 

[My Aswer Is This]

Try this:
Run this script from the sheet named "Sup Tracker" with your sheet names in column A
I assume you have a header row in sheet named "Sup Tracker" so search starts in row(2)

Sub Filter_Me_Please_Array()
'Modified  4/14/2021  6:30:25 AM  EDT
Dim Del As Variant
Del = Array("STEM", "FASS", "WELS", "PVC-S", "FBL") ' Modify Sheet names if needed
Dim lastrow As Long
Dim ans As Long
ans = UBound(Del)
Dim c As Long
Dim counter As Long
counter = 0
c = "1" ' Column Number Modify this to your need
lastrow = Cells(Rows.Count, c).End(xlUp).Row

With Sheets("SUP Tracker").Cells(1, c).Resize(lastrow)

For i = 0 To ans
    .AutoFilter 1, Del(i), Operator:=xlFilterValues
    counter = .Columns(c).SpecialCells(xlCellTypeVisible).Count
    If counter > 1 Then .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets(Del(i)).Cells(2, 1)
counter = 0
Next
.AutoFilter
End With
End Sub