Macro to match cell value to worksheet name and copy all rows and row data

[jamesmcgallan]

Hi, this is my 1st posting, i'm a beginner with vba and have got as far as i can with the problem I've got

I'm using Excel 2010

I have a "Data" sheet which holds all information for orders, I have a macro that looks through the sheet and creates a new worksheet based on the Id's in column A.

What i now need is a Macro to

1 - Copy the column titles to all created sheets
2 - Match the ID in column A to the sheet names and copy the matching rows from "Data" into the sheets with the same name.

this is what i have so far (also attached), thanks in advance.

Sub CreateTabs()

Dim sheetCount As Long
Dim sheetName As String
Dim workbookCount As Integer

With ActiveWorkbook
sheetCount = Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To sheetCount Step 1
sheetName = .Sheets("Data").Range("A" & i).Value
If Not sheetName = "" Then
workbookCount = .Worksheets.Count
If Not DoesSheetExist(sheetName) Then
    .Sheets.Add After:=Sheets(workbookCount)
    .Sheets(.Worksheets.Count).name = sheetName
End If
End If

'.Sheets(.Worksheets.Count).Range("A" & i).Value = .Sheets("Data").Range("A" & i).Value
Next

End With

Worksheets("Data").Activate
Application.Run "CopyRows"

End Sub
' Determines if a sheet name already exists.
Function DoesSheetExist(name As String) As Boolean
    blnFound = False
    With ThisWorkbook
        For i = 1 To .Sheets.Count
                If .Sheets(i).name = name Then
                    blnFound = True
                    Exit For
                End If
        Next i
    End With
    DoesSheetExist = blnFound
End Function

' Copies rows from "Data" to matching worksheet name
Sub CopyRows()
Dim bottomD As Integer
Dim c As Range
Dim ws As Worksheet
    bottomD = Range("A" & Rows.Count).End(xlUp).Row
    For Each c In Sheets("Data").Range("A" & bottomD)
        For Each ws In Sheets
            ws.Activate
            If ws.name = c Then
            c.EntireRow.Copy Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            End If
        Next ws
    Next c
End Sub

inventory example1.xlsm

[AB33]

James,
Welcome to the forum!

Please read forum's rule regarding code tags.
Try the attached.

[jamesmcgallan]

Many thanks, that works great.

Apologies for the lack of code tags, will make sure they are in my next post.

thanks again