asked on

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

StephenJR

Can you post a workbook?

AndyPandy

ASKER

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

wchh

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

wchh

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

wchh

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

ASKER CERTIFIED SOLUTION

StephenJR

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

AndyPandy

ASKER

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

AndyPandy

ASKER

Works well, concise too !
Thank you very much!