asked on

Move data to new sheets

In Sheet1 column 'P' there are country names. [i.e. Spain, France,United States, Canada etc.etc.] this has been sorted in order A-Z

I need to copy the entire row for each group of names [including the header] on to a new tab so that each tab contain the header and just the one country.

would appreciate an expert providing me with the VBA code to do this please

FarWest

please provide a sample sheet

Saqib Husain

Try this macro

Sub c2sheets()
Dim cel As Range
Dim sws As Worksheet
Dim tws As Worksheet
Set sws = ActiveSheet
For Each cel In Range("P2:P" & Range("P" & Rows.Count).End(xlUp).Row)
If cel.Value <> "" Then
Set tws = Worksheets.Add(, Worksheets(Worksheets.Count))
tws.Name = cel.Value
sws.Range("1:1").Copy tws.Range("1:1")
cel.EntireRow.Copy tws.Range("2:2")
End If
Next cel
End Sub

Jagwarman

ASKER

Hi Saqib Husain, Syed

not quite. What it is trying to do is put each row from sheet 1 onto a new sheet and rename that sheet with the name in column P [i.e. Spain]

So if there are 4 rows in Sheet1 with the name Spain in row P it is trying to name every sheet Spain and each sheet would contain only the header and one row.

What I need it to do is; if there are 4 rows with data for Spain put all 4 rows on that new tab then do same for France, Canada etc.

Thanks

FarWest

Thats why I asked for a sample sheet
is there a problem to upload it

Jagwarman

ASKER

File attached
copy-to-new-sheets.xlsx

ASKER CERTIFIED SOLUTION

Rgonzo1971

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Jagwarman

ASKER

perfect Rgonzo thanks

Saqib Husain

The question says country name in P whereas example shows country name in M

Sub c2sheets()
    Dim cel As Range
    Dim sws As Worksheet
    Dim tws As Worksheet
    Set sws = ActiveSheet
    Application.DisplayAlerts = False
    For Each cel In Range("M2:M" & Range("M" & Rows.Count).End(xlUp).Row)
        If cel.Value <> "" Then
            Set tws = Worksheets.Add(, Worksheets(Worksheets.Count))
            On Error Resume Next
            tws.Name = cel.Value
            If Err Then tws.Delete
            On Error GoTo 0
            Set tws = Sheets(cel.Value)
              sws.Range("1:1").Copy tws.Range("1:1")
            cel.EntireRow.Copy Cells(tws.UsedRange.Rows.Count + 1, 1)
        End If
    Next cel
End Sub

Open in new window