Macro to create new worksheet for each column

redjay

New Member
Joined
May 9, 2008
Messages
46
Hello all<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:eek:ffice:eek:ffice" /><o:p></o:p>
<o:p> </o:p>
I have a simple worksheet which has 6 or 7 straightforward columns. Id like some VBA which cycles through the columns, copies the contents of each column in turn and pastes it into a new worksheet for each column (so that I end up with a new tab for each of the columns in the original worksheet).<o:p></o:p>
<o:p> </o:p>
To complicate it slightly, I would like the contents of column A to be copied and pasted into each new tab as well. So in effect the first new tab would have a copy of columns A and B. The 2<SUP>nd</SUP> new tab would have a copy of columns A and C, the 3<SUP>rd</SUP> new tab would have a copy of columns A and D- and so on.<o:p></o:p>
<o:p> </o:p>
I hope that makes sense!<o:p></o:p>
<o:p> </o:p>
Thank you for looking.<o:p></o:p>
 

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.

VoG

Legend
Joined
Jun 19, 2002
Messages
63,650
Try

Code:
Sub copycols()
Dim LC As Long, i As Long, ws As Worksheet
With ActiveSheet
    LC = .Cells(1, Columns.Count).End(xlToLeft).Column
    For i = 2 To LC
        Set ws = Sheets.Add(after:=Sheets(Sheets.Count))
        .Columns(1).Copy Destination:=ws.Range("A1")
        .Columns(i).Copy Destination:=ws.Range("B1")
    Next i
End With
End Sub
 

jim may

Well-known Member
Joined
Jul 4, 2004
Messages
7,484
Peter, I'm trying to fight my way thru this task, and I'm almost there EXCEPT I get a R/T 1004 at line in RED AFTER THE FIRST LOOP - Error is occuring when i = 3
Everything works OK with i = 2... Can you assist me in what I'm doing wrong?
Tks,
Jim

Rich (BB code):
Sub Foo()
Dim Wk1 As Worksheet  'original worksheet (1 of 1)
Dim LCol As Long, TotSheets As Long
LCol = Cells(1, Columns.Count).End(xlToLeft).Column
TotSheets = LCol
Set Wk1 = Worksheets(1)
Set ColA = Wk1.Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
For i = 2 To TotSheets
    Set ColNxt = Wk1.Range(Cells(1, i), Cells(Rows.Count, i).End(xlUp))
    Worksheets.Add After:=Worksheets(Worksheets.Count)
    ColA.Copy Destination:=ActiveSheet.Range("A1")
    ColNxt.Copy Destination:=ActiveSheet.Cells(1, i)
    Set ColNxt = Nothing
Next i
End Sub
 

VoG

Legend
Joined
Jun 19, 2002
Messages
63,650

ADVERTISEMENT

Hi Jim. Maybe

Rich (BB code):
    Set ColNxt = Wk1.Range(Wk1.Cells(1, i), Wk1.Cells(Rows.Count, i).End(xlUp))
 

redjay

New Member
Joined
May 9, 2008
Messages
46
Thanks again guys.

I wonder if you know how I might rename each tab/worksheet to match the value in cell B2 (in each new sheet) ?

I only really know how to do it using activesheet. but this does not work in this case?

Many thanks
 

jim may

Well-known Member
Joined
Jul 4, 2004
Messages
7,484
Obvioulsy, Wk1.Range() is not enough. It's the old "fully qualified" requirement again...
Thank you so much = My Final Working Code (Below)

Code:
Sub Foo()  'This macro ASSUMES their is ONLY 1 Sheet in the Workbook before running Foo
Dim Wk1 As Worksheet  'original worksheet (1 of 1)
Dim LCol As Long, TotSheets As Long
Dim ColA As Range, ColNxt As Range
Application.ScreenUpdating = False
LCol = Cells(1, Columns.Count).End(xlToLeft).Column
TotSheets = LCol
Set Wk1 = Worksheets(1)
Set ColA = Wk1.Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
For i = 2 To TotSheets
    Set ColNxt = Wk1.Range(Wk1.Cells(1, i), Wk1.Cells(Rows.Count, i).End(xlUp))
    Worksheets.Add After:=Worksheets(Worksheets.Count)
    ColA.Copy Destination:=ActiveSheet.Range("A1")
    ColNxt.Copy Destination:=ActiveSheet.Range("B1")
    Set ColNxt = Nothing
Next i
Wk1.Activate
Application.ScreenUpdating = True
End Sub
 

VoG

Legend
Joined
Jun 19, 2002
Messages
63,650
Try

Code:
Sub copycols()
Dim LC As Long, i As Long, ws As Worksheet
With ActiveSheet
    LC = .Cells(1, Columns.Count).End(xlToLeft).Column
    For i = 2 To LC
        Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
        .Columns(1).Copy Destination:=ws.Range("A1")
        .Columns(i).Copy Destination:=ws.Range("B1")
        ws.Name = Range("B2").Value
    Next i
End With
End Sub
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,163,487
Messages
5,831,982
Members
430,100
Latest member
namhnz

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