Copy and paste multiple rows of data to a specific column in another sheet based on tab name

[Mel2016]

Hi,

i have the following code that work great for one row of data (copy/paste/transpose) but I am trying to tweak it because I know have multiple rows Of data per employee and don't need to transpose it just paste it. What I need to do is lookup the value in the master for the tab name and find all the rows that match then copy and paste all of them that into the individual named tab that matches starting at s2.


Sub populateSheets()

Set empSheet = Sheets("Employee Sheet")

lr = empSheet.Range("A" & Rows.Count).End(xlUp).Row

For each c In empSheet.Range("A1:A" & lr)

If wsExists(c.Text) then
empSheet.Range("A" & c.Row &":CU" & c.Row).Copy
Sheets(c.Text).Range("G2").PasteSpecial Transpose:=True
else
MsgBox "Worksheet " & c.Text & " not found
End If

Next

End Sub

Function wsExists(ByVal sName As String) As Boolean

wsExists = False
For each ws In Worksheets
If sName = ws.Name Then
wsExists = True
Exit Function
End if
Next ws

End Function

 

[JLGWhiz]

See if this will do what you want.

 Sub populateSheets()
 Set empSheet = Sheets("Employee Sheet")
 lr = empSheet.Range("A" & Rows.Count).End(xlUp).Row
    For Each c In empSheet.Range("A1:A" & lr)
        If wsExists(c.Text) Then
            empSheet.Range("A1:CU" & lr).AutoFilter 1, c.Text
            'empSheet.Range("A" & c.Row &":CU" & c.Row).Copy
            'Sheets(c.Text).Range("G2").PasteSpecial Transpose:=True
            empSheet.Range("A2:Cu" & lr).SpecialCells(xlCellTypeVisible).Copy Sheets(c.Text).Cells(Rows.Count, "S").End(xlUp)(2)
            empSheet.AutoFilterMode = False 
        Else
            MsgBox "Worksheet " & c.Text & " not found"
        End If
    Next
 End Sub

 

[Mel2016]

Unfortunately, it's not working. It's getting stuck in a loop or something. The are over 15k rows but only 77 unique emp Ids. Can't figure out why? Copied the text twice...

 

[JLGWhiz]

Unfortunately, it's not working. It's getting stuck in a loop or something. The are over 15k rows but only 77 unique emp Ids. Can't figure out why? Copied the text twice...

Let's try it this way.

Sub populateSheets()
 Set empSheet = Sheets("Employee Sheet")
 lr = empSheet.Range("A" & Rows.Count).End(xlUp).Row
 empSheet.Range("A1:A" & lr).AdvancedFilter xlFilterCopy, , empSheet.Range("B" & lr + 2), True
    For Each c In empSheet.Range("B" & lr + 3, Cells(Rows.Count, 2).End(xlUp))
        If wsExists(c.Text) Then
            empSheet.Range("A1:CU" & lr).AutoFilter 1, c.Text
            'empSheet.Range("A" & c.Row &":CU" & c.Row).Copy
            'Sheets(c.Text).Range("G2").PasteSpecial Transpose:=True
            empSheet.Range("A2:Cu" & lr).SpecialCells(xlCellTypeVisible).Copy Sheets(c.Text).Cells(Rows.Count, "S").End(xlUp)(2)
            empSheet.AutoFilterMode = False
        Else
            MsgBox "Worksheet " & c.Text & " not found"
        End If
    Next
    empSheet.Range("B" & lr + 2).CurrentRegion.ClearContents
 End Sub

It was just repeating the filtering 15K times, due to my oversight. this will probably still take a minute or two because of the size, but should not take much more than that.

 

[Mel2016]

I really appreciate the help but it got stuck on the 4th line of the code at the top. "empSheet.Range("A1:A") & lr).Advanced.Fiter...etc. I got a run-time error 438- property or method doesn't exist...

 

[JLGWhiz]

I really appreciate the help but it got stuck on the 4th line of the code at the top. "empSheet.Range("A1:A") & lr).Advanced.Fiter...etc. I got a run-time error 438- property or method doesn't exist...

In a test set up with the main sheet named 'Employee Sheet' and the other sheet names listed down column A beginning in cell A2, the code ran without error and produced expected results. I cannot duplicate the error you are getting while using the the last code that I posted. Check all your spelling (Filter v. Fiter), make sure the code is in the standard code module, be sure the ranges specified in the code are compatible with the data layout on the worksheet.

 

[Mel2016]

Well, it is running now but it only populated two sheets (which are the first two worksheets) and then indicated the rest were not found. The data for all tabs is in the Emplyee Sheet so I'm sure we're the error is. Help... And thanks!!!!


Sub PopulateSheets()
Set empSheet = Sheets("Employee Sheet")
lr = empSheet.Range("A" & Rows.Count).End(xlUp).Row
empSheet.Range("A1:A" & lr).AdvancedFilter xlFilterCopy, , empSheet.Range("B" & lr + 2), True

For Each c In empSheet.Range("B" & lr + 3, Cells(Rows.Count, 2).End(xlUp))
If wsExists(c.Text) Then
empSheet.Range("A1:CU" & lr).AutoFilter 1, c.Text
empSheet.Range("A2:CU" & lr).SpecialCells(xlCellTypeVisible).Copy Sheets(c.Text).Cells(Rows.Count, "S").End(xlUp)(2)
empSheet.AutoFilterMode = False

Else
MsgBox "Worksheet" & c.Text & "not found"
End If

Next
empSheet.Range("B" & lr + 2).CurrentRegion.ClearContents

End Sub

Function wsExists(ByVal sName As String) As Boolean

wsExists = False
For Each ws In Worksheets
If sName = ws.Name Then
wsExists = True
Exit Function
End If
Next ws
End Function

 

[JLGWhiz]

You can try these modified versions to see if it is leadin or trailing blanks that is causing the mis-match.

Sub PopulateSheets()
 Set empSheet = Sheets("Employee Sheet")
 lr = empSheet.Range("A" & Rows.Count).End(xlUp).Row
 empSheet.Range("A1:A" & lr).AdvancedFilter xlFilterCopy, , empSheet.Range("B" & lr + 2), True
     For Each c In empSheet.Range("B" & lr + 3, Cells(Rows.Count, 2).End(xlUp))
         If wsExists(Trim(c.Text)) Then
             empSheet.Range("A1:CU" & lr).AutoFilter 1, Trim(c.Text)
             empSheet.Range("A2:CU" & lr).SpecialCells(xlCellTypeVisible).Copy Sheets(Trim(c.Text)).Cells(Rows.Count, "S").End(xlUp)(2)
             empSheet.AutoFilterMode = False
         Else
             MsgBox "Worksheet" & c.Text & "not found"
         End If
     Next
 empSheet.Range("B" & lr + 2).CurrentRegion.ClearContents
 End Sub

 Function wsExists(ByVal sName As String) As Boolean
 wsExists = False
     For Each ws In ThisWorkbook.Worksheets
          If sName = Trim(ws.Name) Then
             wsExists = True
             Exit Function
         End If
     Next ws
 End Function

 

[Mel2016]

Success! Thank you very much.. Works like a charm.

 

[JLGWhiz]

Success! Thank you very much.. Works like a charm.

What you need to do is go through your list in column A of Employee Sheet and make sure that only the name is entered without any spaces before or after them. Then do the same for your sheet name tabs. That is apparently where your problem stemmed from. For column A it will be easy. Select the column then use the replace dialog box in Excel and in the Find What area put " ". That is a space enclosed in quotes. In the Replace With area, leave blank and click Replace All. Be sure you only have column A selected.
Regards, JLG