Copy data from 1 sheet to multiple worksheets

[Rob P]

I have data in columns in one worksheet

each set has two columns separated by a blank column

I wish to copy both columns of each set onto a new worksheet (renamed
with Row 1 name)


A B C D E F G H more data
accross
1 XX YY ZZ
2 Y 91 A 5 D 55
3 Z 92 B 6 E 66

columns C, F, I etc are blank - separating the data

i.e.
create new worksheet labelled "XX" with columns A and B pasted in A
and B
and new worksheet "YY" with columns D and E pasted in A and B
and new worksheet "ZZ" with columns G and H pasted in A and B

looping through all the data in the sheet (over 600 sets)


any help appreciated

thanks
Rob

 

[joel]

Sub SplitData()

Set Oldsht = ActiveSheet
With Oldsht
LastCol = .Cells(2, Columns.Count).End(xlToLeft).Column
For Colcount = 1 To LastCol Step 3
Set NewSht = Sheets.Add(after:=Sheets(Sheets.Count))
Label = .Cells(1, Colcount)
NewSht.Name = Label
LastRow = .Cells(Rows.Count, Colcount).End(xlUp).Row
.Range(.Cells(2, Colcount), .Cells(LastRow, Colcount + 1)).Copy _
Destination:=NewSht.Range("A1")
Next Colcount
End With
End Sub

 

[Rob P]

Sub SplitData()

Set Oldsht = ActiveSheet
With Oldsht
   LastCol = .Cells(2, Columns.Count).End(xlToLeft).Column
   For Colcount = 1 To LastCol Step 3
      Set NewSht = Sheets.Add(after:=Sheets(Sheets.Count))
      Label = .Cells(1, Colcount)
      NewSht.Name = Label
      LastRow = .Cells(Rows.Count, Colcount).End(xlUp).Row
      .Range(.Cells(2, Colcount), .Cells(LastRow, Colcount + 1)).Copy _
         Destination:=NewSht.Range("A1")
   Next Colcount
End With
End Sub













- Show quoted text -

perfect - thank you Joel

(apologies did not realise my request was posted on two separate
sites?!?!)