Generate new workbook and add a template header with multiple rows

Question

I have compiled a Macro to generate new workbooks based on unique values i the original workbook. Then it copies the rows related to thees values into the new workbook. This works great.

However I also want a template to be copied after this process and inserted as new rows in the new workbook. I am having trouble activating this new workbook to run these actions.

I am guessing that the new workbook needs to be set to something so I can use this as a reference. To later be used in this part: Windows("newBook").Activate. Or should this part be written completely different?

And when should the new workbook be saved to set it´s name? Using this part ActiveWorkbook.SaveAs SavePath & ArrayOfUniqueValues(ArrayItem) & ".xlsx", 51

This is what I have so far:

Option Explicit

Sub DataExport()

'Declare variables
Dim ArrayItem As Long
Dim ws As Worksheet
Dim NewBook As Workbook
Dim ArrayOfUniqueValues As Variant
Dim SavePath As String
Dim ColumnHeadingInt As Long
Dim ColumnHeadingStr As String
Dim rng As Range

Set ws = Sheets("Data")
Set NewBook = 'what?

'The save path for the files created
SavePath = Range("FolderPath")

'Variables for the column to separate data based on
ColumnHeadingInt = WorksheetFunction.Match(Range("ExportCriteria").Value, Range("Data[#Headers]"), 0)
ColumnHeadingStr = "Data[[#All],[" & Range("ExportCriteria").Value & "]]"

'Turn off screen updating to save runtime
Application.ScreenUpdating = False

'Creates a temporary list of unique values
Range(ColumnHeadingStr & "").AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=Range("UniqueValues"), Unique:=True

'Sort the temporary list of unique values
ws.Range("UniqueValues").EntireColumn.Sort Key1:=ws.Range("UniqueValues").Offset(1, 0), _
    Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
    Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

'Add unique field values into an array
ArrayOfUniqueValues = Application.WorksheetFunction.Transpose(ws.Range("UniqueValues").EntireColumn.SpecialCells(xlCellTypeConstants))

'Delete the temporary values
ws.Range("UniqueValues").EntireColumn.Clear

'Loop through the array of unique field values. Then copy paste into new workbooks and save.
For ArrayItem = 1 To UBound(ArrayOfUniqueValues)
    ws.ListObjects("Data").Range.AutoFilter Field:=ColumnHeadingInt, Criteria1:=ArrayOfUniqueValues(ArrayItem)
    ws.Range("Data[#All]").SpecialCells(xlCellTypeVisible).Copy
    Workbooks.Add
            Range("A1").PasteSpecial xlPasteAll ' pastes all values
            Columns(1).EntireColumn.Delete

'saving the new workbook. Should it be places somewhere else?
  ActiveWorkbook.SaveAs SavePath & ArrayOfUniqueValues(ArrayItem) & ".xlsx", 51

'here is where the trouble starts
    Windows("REFERENCE with export VB.xlsm").Activate
    Sheets("Template").Select
    Rows("1:5").Select
    Selection.Copy

'Now the tricky part on how to go back to the new workbook
    Windows("newBook").Activate
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown

'Saving and closing    
            ActiveWorkbook.Save
    ActiveWorkbook.Close False
    ws.ListObjects("Data").Range.AutoFilter Field:=ColumnHeadingInt
Next ArrayItem

ws.AutoFilterMode = False
MsgBox "Finished exporting!"
Application.ScreenUpdating = True

End Sub

You shouldn't activate any workbook or worksheet. To do that you can use `Worksheet` and `Workbook` variables. You can find more info [here](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba). Actually you are using them, instead just adding a new workbook, add it the variable. `Set NewBook = Workbooks.Add(...)` this way you can reference the new workbook by your variable `NewBook` — Damian, Dec 04 '19 at 11:06
Thanks. I cannot figure out what you want me to use instead of your 3 dots. Sorry for being stupid. :-P — Åsa, Dec 04 '19 at 11:55

Damian · Accepted Answer · 2019-12-04T12:57:12.973

I've tried to explain the code so it makes sense. I don't know what do you actually want to do with the copied rows from the sheet templates, I've assumed you wanted to paste the format to the first 5 rows of your new workbok...

Option Explicit
Sub DataExport()

    'Turn off screen updating to save runtime
    Application.ScreenUpdating = False 'do it at the beginning of your code

    'Declare variables
    'try to declare your variables just before using them so it's easier to know what do they do.


    'Dim rng As Range you are not using this

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Data") 'always reference workbook and worksheet

    'The save path for the files created
    Dim SavePath As String
    SavePath = Range("FolderPath")

    With ws 'you can use this to reference this worksheet using only a dot
        'Variables for the column to separate data based on
        Dim ColumnHeadingInt As Long
        ColumnHeadingInt = WorksheetFunction.Match(.Range("ExportCriteria").Value, .Range("Data[#Headers]"), 0)

        Dim ColumnHeadingStr As String
        ColumnHeadingStr = "Data[[#All],[" & .Range("ExportCriteria") & "]]"

        'Creates a temporary list of unique values
        .Range(ColumnHeadingStr & "").AdvancedFilter Action:=xlFilterCopy, _
            CopyToRange:=.Range("UniqueValues"), Unique:=True

        'Sort the temporary list of unique values
        .Range("UniqueValues").EntireColumn.Sort Key1:=ws.Range("UniqueValues").Offset(1, 0), _
            Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
            Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

        'Add unique field values into an array
        Dim ArrayOfUniqueValues As Variant
        ArrayOfUniqueValues = Application.WorksheetFunction.Transpose(.Range("UniqueValues").EntireColumn.SpecialCells(xlCellTypeConstants))

        'Delete the temporary values
        .Range("UniqueValues").EntireColumn.Clear

    End With 'here ends the reference to your ws sheet

    'You shouldn't declare anything inside a loop, so you do it just before.
    Dim NewBook As Workbook

    'Loop through the array of unique field values. Then copy paste into new workbooks and save.
    Dim ArrayItem As Long
    For ArrayItem = LBound(ArrayOfUniqueValues) To UBound(ArrayOfUniqueValues)
        .ListObjects("Data").Range.AutoFilter Field:=ColumnHeadingInt, Criteria1:=ArrayOfUniqueValues(ArrayItem)
        .Range("Data[#All]").SpecialCells(xlCellTypeVisible).Copy

        'Here you use the NewBook variable.
        Set NewBook = Workbooks.Add 'you can use the workbook variable like this
        With NewBook.Sheets(1)
            .Range("A1").PasteSpecial xlPasteAll ' pastes all values
            .Columns(1).EntireColumn.Delete
            .Rows("1:1").Insert Shift:=xlDown
        End With

    'here is where the trouble starts this block can be resumed in one line of code
'        Windows("REFERENCE with export VB.xlsm").Activate
'        Sheets("Template").Select
'        Rows("1:5").Select
'        Selection.Copy

    'ThisWorkbook always refers to the workbook running the code
    ThisWorkbook.Sheets("Template").Rows("1:5").Copy

    With NewBook 'again reference the new workbook
        'This I think is what you want to do, paste formats from rows 1 to 5 on your Template sheet
        .Sheets(1).Range("A1").PasteSpecial xlPasteFormats

        'saving the new workbook. Should it be places somewhere else?
        'Should be placed just before the last operation so you don't need to save multiple times
        .SaveAs SavePath & ArrayOfUniqueValues(ArrayItem) & ".xlsx", 51
        .Close
    End With

        ws.ListObjects("Data").Range.AutoFilter Field:=ColumnHeadingInt
    Next ArrayItem

    ws.AutoFilterMode = False
    MsgBox "Finished exporting!"
    Application.ScreenUpdating = True

End Sub

Thanks! Now I understand the jumping in between workbooks better. I got my macro to work using your tips. — Åsa, Dec 04 '19 at 13:51
@Åsa I'm glad you could make it work. If this answer helped you, please consider upvoting/accepting it as correct. — Damian, Dec 04 '19 at 13:59

Generate new workbook and add a template header with multiple rows

1 Answers1