Macro to create new worksheet for each column

[redjay]

Hello all<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
<o> </o>
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></o>
<o> </o>
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></o>
<o> </o>
I hope that makes sense!<o></o>
<o> </o>
Thank you for looking.<o></o>

 

[VoG]

Try

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

 

[redjay]

Seems to work perfectly.

Many many thanks

 

[jim may]

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

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]

Hi Jim. Maybe

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

 

[redjay]

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]

Obvioulsy, Wk1.Range() is not enough. It's the old "fully qualified" requirement again...
Thank you so much = My Final Working Code (Below)

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]

Try

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