VBA saving multiple workbooks

[Dolphin1]

I am trying to create multiple workbooks by replacing 5 cells of data (from another workbook) to reflect a new employee's information and save under that person's name. I am a bit out of my league here. I recorded a macro by copying/pasting data from the source workbook that is storing the person's information to the workbook I want to update and save. But I have no idea how to change the code to automate this so a new workbook is updated with those 5 lines and then saved under a new name from each row of the source file. Here is what the recorded macro looks like:

Sub IMPS()
'
' IMPS Macro
'
' Keyboard Shortcut: Ctrl+Shift+X
'
Selection.Copy
Windows("2017 YTD Template CASH V2.xlsm").Activate
Range("B4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("FTE - IMPS.xlsx").Activate
Range("B2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("2017 YTD Template CASH V2.xlsm").Activate
Range("B5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("FTE - IMPS.xlsx").Activate
Range("C2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("2017 YTD Template CASH V2.xlsm").Activate
Range("B6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("FTE - IMPS.xlsx").Activate
Range("D2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("2017 YTD Template CASH V2.xlsm").Activate
Range("B7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("FTE - IMPS.xlsx").Activate
Range("E2").Select
Application.CutCopyMode = False
Selection.Copy
Windows("2017 YTD Template CASH V2.xlsm").Activate
Range("B8").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents\Scorecards\2017 YTD Scorecard.xlsm" _
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Windows("FTE - IMPS.xlsx").Activate
End Sub

Can anyone help me edit this so it will create a new workbook for every employee in my source file? Thank you!!

 

[JackDanIce]

Re: VBA / Macro help for saving multiple workbooks

Welcome to the board. Untested, however, try:

Sub IMPS()

    Dim LR      As Long
    Dim x       As Long
    Dim arr()   As Variant
        
    Application.ScreenUpdating = False
        
    With Workbooks("2017 YTD Template CASH V2.xlsm")
        With ActiveSheet
        LR = .Cells(.Rows.count, 1).End(xlUp).row
        For x = 2 To LR
            arr = .Cells(x, 1).Resize(, 5).Value
            Workbooks("FTE - IMPS.xlsx").ActiveSheet.Range("B2").Resize(UBound(arr, 2), UBound(arr, 1)).Value = Application.Transpose(arr)
            .SaveAs "C:\Documents\Scorecards\2017 YTD Scorecard " & arr(1, 1) & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
            Erase arr
        Next x
    End With
    
    Application.ScreenUpdating = True
    
End Sub

 

[Dolphin1]

Re: VBA / Macro help for saving multiple workbooks

Thanks! It is giving me an error, "Expected End With" ? I don't know enough about this to know what that means

 

[JackDanIce]

VBA / Macro help for saving multiple workbooks

Sorry, try:

Sub IMPS()

    Dim LR      As Long
    Dim x       As Long
    Dim arr()   As Variant
        
    Application.ScreenUpdating = False
        
    With Workbooks("2017 YTD Template CASH V2.xlsm")
        With ActiveSheet
            LR = .Cells(.Rows.count, 1).End(xlUp).row
            For x = 2 To LR
                arr = .Cells(x, 1).Resize(, 5).Value
                Workbooks("FTE - IMPS.xlsx").ActiveSheet.Range("B2").Resize(UBound(arr, 2), UBound(arr, 1)).Value = Application.Transpose(arr)
                .SaveAs "C:\Documents\Scorecards\2017 YTD Scorecard " & arr(1, 1) & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
                Erase arr
            Next x
        End With
    End With
    
    Application.ScreenUpdating = True
    
End Sub

 

[Dolphin1]

Re: VBA / Macro help for saving multiple workbooks

Getting a run time error '9' - subscript out of range on line: Workbooks("FTE - IMPS.xlsx").ActiveSheet.Range("B2").Resize(UBound(arr, 2), UBound(arr, 1)).Value = Application.Transpose(arr) There are actually 5 columns of data (B2-E73) in the source file to be copied, so do I need 5 array's? I tried adding more but can't get it to work. Thanks again for your help!

 

[JackDanIce]

Re: VBA / Macro help for saving multiple workbooks

What are the names of the sheet you are copying from and pasting to in 2017 YTD Template CASH V2 and FTE - IMPS respectively?

And 5 columns or 4? B2:E73 suggests 4

 

[Dolphin1]

Re: VBA / Macro help for saving multiple workbooks

Copying from FTE - IMPS, pasting into 2017 YTD Template CASH V2 and then saving 2017 YTD Template CASH V2 as a new file name for each person. And the columns are actually A2:E73 in the FTE - IMPS file - sorry, losing my mind a bit. Those get pasted to B4:B8 in the 2017 YTD Template CASH V2 file (so A2 to B4, B2 to B5, etc.) Thanks!!

 

[JackDanIce]

Re: VBA / Macro help for saving multiple workbooks

Those are the names of the files, I do not believe they are the names of the worksheets. Please state the names of the worksheets (or tabs) in those workbooks...

E.g. Copy from Sheet1 in FTE - IMPS.xlsx A2:E2 to Sheet2 in 2017 YTD Template CASH V2, transposed to B4:B8

 

[Dolphin1]

Re: VBA / Macro help for saving multiple workbooks

Oh, gotcha - both are Sheet1; Copy from Sheet1 in FTE - IMPS.xlsx, A2:E2 to Sheet1 in 2017 YTD Template CASH V2, B4:B8 Thanks!

 

[JackDanIce]

Re: VBA / Macro help for saving multiple workbooks

Try:

Sub IMPS()


    Dim LR      As Long
    Dim x       As Long
    Dim arr()   As Variant
        
    Application.ScreenUpdating = False
        
    With Workbooks("2017 YTD Template CASH V2.xlsm")
        With .Sheets("Sheet1")
            LR = .Cells(.Rows.count, 1).End(xlUp).row
            For x = 2 To LR
                arr = .Cells(x, 1).Resize(, 5).Value
                Workbooks("FTE - IMPS.xlsx").Sheets("Sheet1").Range("B2").Resize(UBound(arr, 2), UBound(arr, 1)).Value = Application.Transpose(arr)
                .SaveAs "C:\Documents\Scorecards\2017 YTD Scorecard " & arr(1, 1) & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
                Erase arr
            Next x
        End With
    End With
    
    Application.ScreenUpdating = True
    
End Sub