Create workbooks from worksheet columns, naming new workbook with worksheet header

Hi Experts,

I need to create workbooks from worksheet columns, naming each new workbook with corresponding worksheet header.

The immediate problem I am having is:
 how to get Column header name to rename the new workbook.

See pics and code below.

Thanks for looking.
   
Sub Macro4()
'
' Macro4 Macro
'

'
    Columns("A:B").Select
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    Windows("Excel Class Schedule (version 1).xlsb [Autosaved]").Activate
    Columns("C:C").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Book1").Activate
    Range("C1").Select
    ActiveSheet.Paste
    Range("C1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "Jay"
    ActiveWorkbook.SaveAs Filename:="C:\Users\A\Documents\Jay.xlsx", FileFormat _
        :=xlOpenXMLWorkbook, CreateBackup:=False
    Windows("Excel Class Schedule (version 1).xlsb [Autosaved]").Activate
End Sub

Open in new window

Capture-Worksheet2.JPG
Capture-worksheet1.JPG
AndyPandyAsked:
Who is Participating?
 
StephenJRCommented:
Here is one approach. I tested briefly and it seems to work.
Sub x()
 
Dim r As Long, c As Long

With ThisWorkbook.Sheets("Sheet1")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    For c = 3 To .Cells(2, Columns.Count).End(xlToLeft).Column
        Union(.Range("A2:B" & r), .Range(.Cells(2, c), .Cells(r, c))).Copy ThisWorkbook.Sheets("Sheet2").Range("A1")
        ThisWorkbook.Sheets("Sheet2").Copy
        ActiveWorkbook.Close SaveChanges:=True, Filename:="C:\Users\A\Documents\" & .Cells(2, c) & ".xlsx"
        ThisWorkbook.Sheets("Sheet2").UsedRange.Clear
    Next c
End With
     
End Sub

Open in new window

0
 
StephenJRCommented:
Can you post a workbook?
0
 
AndyPandyAuthor Commented:
Temp-Master.xlsx
StephenJR, per your request,

Attached is  the xlsx file Temp_Master.xlsx.
I am seeking a way of parsing for each name (columns C through J),
columns A & B and a named column (C through J),
into a new workbook, named with name of the column being parsed.
Thanks
0
Cloud Class® Course: Ruby Fundamentals

This course will introduce you to Ruby, as well as teach you about classes, methods, variables, data structures, loops, enumerable methods, and finishing touches.

 
wchhCommented:
Try macro below
Sub TestExcel()

Dim Wk As Workbook
Dim i As Long
With ActiveWorkbook.ActiveSheet
For i = 3 To .UsedRange.Columns.Count
    Set Wk = Workbooks.Add
    Application.DisplayAlerts = False
    Wk.Application.Visible = False
    'Copy WorkSheet
    .Columns("A:B").Copy
    Wk.Sheets("Sheet1").Range("A1").Select
    ActiveSheet.Paste
    .Columns(i).Copy
    Wk.Sheets("Sheet1").Range("C1").Select
    ActiveSheet.Paste
    'Save & Close
    Wk.SaveAs ("C:\Users\A\Documents\" & Trim(.Cells(1, i).Value) & ".xlsx")
    Wk.Close
Next i
End With

End Sub

Open in new window

0
 
wchhCommented:
Amended
Sub TestExcel()

Dim Wk As Workbook
Dim i As Long
With ActiveWorkbook.ActiveSheet
For i = 3 To .UsedRange.Columns.Count
If Trim(.Cells(2, i).Value) <> "" Then
    Set Wk = Workbooks.Add
    Application.DisplayAlerts = False
    Wk.Application.Visible = False
    'Copy WorkSheet
    .Columns("A:B").Copy
    Wk.Sheets("Sheet1").Range("A1").Select
    ActiveSheet.Paste
    .Columns(i).Copy
    Wk.Sheets("Sheet1").Range("C1").Select
    ActiveSheet.Paste
    'Save & Close
    Wk.SaveAs ("C:\Users\A\Documents\" & Trim(.Cells(2, i).Value) & ".xlsx")
    Wk.Close
    End If
Next i
End With

End Sub

Open in new window

0
 
wchhCommented:
Please remove line
    Wk.Application.Visible = false
Sub TestExcel()

Dim Wk As Workbook
Dim i As Long
With ActiveWorkbook.ActiveSheet
For i = 3 To .UsedRange.Columns.Count
If Trim(.Cells(2, i).Value) <> "" Then
    Set Wk = Workbooks.Add
    Application.DisplayAlerts = False
    'Copy WorkSheet
    .Columns("A:B").Copy
    Wk.Sheets("Sheet1").Range("A1").Select
    ActiveSheet.Paste
    .Columns(i).Copy
    Wk.Sheets("Sheet1").Range("C1").Select
    ActiveSheet.Paste
    'Save & Close
    Wk.SaveAs ("C:\temp\" & Trim(.Cells(2, i).Value) & ".xlsx")
    Wk.Close
    End If
Next i
End With


End Sub

Open in new window

0
 
AndyPandyAuthor Commented:
Hi wchh,  thanks for your work.... there seems to be a bug & only Jay.xlsx (the first column was written out).

0
 
AndyPandyAuthor Commented:
Works well,  concise too !
Thank you very much!
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.