VBA to copy and Paste certain data

DrH100

Board Regular
Joined
Dec 30, 2011
Messages
72
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

HTML:
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
 

Some videos you may like

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
6,393
Office Version
  1. 2019
Platform
  1. Windows
Hi,
see if this change to your code helps.

Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,123,391
Messages
5,601,391
Members
414,448
Latest member
Jessica 22664

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top