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>
 

Some videos you may like

Excel Facts

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.

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,471
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,471
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
 

Watch MrExcel Video

Forum statistics

Threads
1,108,956
Messages
5,525,883
Members
409,669
Latest member
JDCupps

This Week's Hot Topics

Top