VBA to copy and Paste certain data

[DrH100]

I'll try and explain my requirement and what I've done so far and I hope someone can steer me accordingly.

I have a spreadsheet with data in Column a:aa (the number of rows will vary each wee but is 5000+)

What I am trying to do is to have a macro look at column a and depending on the value copy and paste that row into a worksheet named the same as the value

I have tried to use

Application.ScreenUpdating = False
    Dim rCell As Range
    Dim lastrow As Long
    lastrow = Sheets("Data").UsedRange.Rows.Count
    For Each rCell In Worksheets("Data").Range("A2:A" & lastrow).SpecialCells(xlCellTypeConstants)
  

        Worksheets("Data").Rows(1).EntireRow.Copy Worksheets(rCell.Value).Rows(1)
        Worksheets(rCell.Value).Range("A" & Rows.Count).End(xlUp)(2).EntireRow.Value = _
        rCell.EntireRow.Value

    Next rCell
    Application.ScreenUpdating = True

End Sub

Which seems to work ok but my problem occurs if a value in column A is one that doesn't correspond with a worksheet name that already exists.

Is it possible to ammend the code so that if the value in column A does not have a corresponding worksheet that one is created (named the same as the value) and then the data is copied across.

Any help appreciated

 

[dmt32]

Hi,
see if this change to your code helps.

Sub CopyData()
    Application.ScreenUpdating = False
    Dim rCell As Range
    Dim lastrow As Long
    Dim ws As Worksheet
    lastrow = Sheets("Data").UsedRange.Rows.Count
    For Each rCell In Worksheets("Data").Range("A2:A" & lastrow).SpecialCells(xlCellTypeConstants)
        On Error Resume Next
        Set ws = Worksheets(rCell.Value)
        If Err.Number = 9 Then
            Set ws = Worksheets.Add(After:=Sheets(Sheets.Count))
            ws.Name = rCell.Value
        End If
        On Error GoTo 0
        Worksheets("Data").Rows(1).EntireRow.Copy ws.Rows(1)
        Worksheets(rCell.Value).Range("A" & Rows.Count).End(xlUp)(2).EntireRow.Value = _
        rCell.EntireRow.Value
    Next rCell
    Application.ScreenUpdating = True
End Sub

Dave

 

[DrH100]

That works brilliantly thanks very much for your help

 

[dmt32]

That works brilliantly thanks very much for your help

welcome thanks for feedback

Dave