Copy Data To Sheet Name That Matches Values

[benntw]

I have a spreadsheet that has data from A3 to J3. Starting on H3 I have values that are the same as my sheet names. I'd like to copy all the values to each sheet from the match in column H. Can anyone help with this ? On each sheet the name is also in A1. The headers match on each sheet to the main sheet. Thanks for the help.

 

[JLGWhiz]

Sub t()
Dim sh As Worksheet, c As Range
Set sh = ActiveSheet 'Assumes main sheet is the active sheet.
    With sh
        For Each c In .Range("H3", .Cells(Rows.Count, 8).End(xlUp))
            c.EntireRow.Copy Sheets(c.Value).Cells(Rows.Count, 1).End(xlUp)(2)
        Next
    End With
End Sub

 

[benntw]

Appreciate the help. I think my data is too large. It is locking up my workbook. Right now I have 16 sheet names to copy data to. I will end up having 30 sheet names when I am done.

 

[JLGWhiz]

Try this version and see if it still locks up.

Sub t2()
Dim sh As Worksheet, c As Range
Set sh = ActiveSheet 'Assumes main sheet is the active sheet.
    With sh
        .Range("H2", .Cells(Rows.Count, 8).End(xlUp)).AdvancedFilter xlFilterCopy, , .Cells(Rows.Count, 1).End(xlUp)(3), True
        For Each c In .Cells(Rows.Count, 1).End(xlUp).CurrentRegion.Offset(1)
            If c <> "" Then
                .UsedRange.AutoFilter 8, c.Value
                .Range("H3", .Cells(Rows.Count, 8).End(xlUp)).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets(c.Value). _
                Cells(Rows.Count, 1).End(xlUp)(2)
                .AutoFilterMode = False
            End If
        Next
        .Cells(Rows.Count, 1).End(xlUp).CurrentRegion.ClearContents
    End With
End Sub

 

[benntw]

Works like a dream. Thank you very much for your help.

 

[JLGWhiz]

Works like a dream. Thank you very much for your help.

You're welcome,
regards, JLG