0

Looking to have an Excel-VBA that fills a "Template" sheet based on a row/table's info and save as individual sheets.

Worksheet "DataSource" layout is Columns A-AB (headers in row1)
The goal is that for each "IB#" (column B), it populates a template based on the "IB#" row's information and generates a new excel file per IB#

I broke it down into 4 steps:

1) I was generating a new sheet per IB

    Sub makeSheets()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range
Set sh1 = Sheets("Template")
Set sh2 = Sheets("DataSource")
    For Each c In sh2.Range("B2", sh2.Cells(Rows.Count, 2).End(xlUp))
        sh1.copy After:=Sheets(Sheets.Count)
        ActiveSheet.name = c.Value
        ActiveSheet.Range("A9") = ActiveSheet.name
    Next
End Sub

2) I was able to fill the Template (Test Sheet) the following way but I was wondering if it can be optimized to fill all of created ones

Sub AAA_Refresh_Temp()
    'filling Template
    Call AAA_Fill_Temp
    With Sheets("DataSource")
        .Range("B2", .Range("B2").End(xlDown)).name = "IB_Accounts"
        .Range("C2", .Range("C2").End(xlDown)).name = "IB_Information"
        .Range("AA2", .Range("AA2").End(xlDown)).name = "IB_Adress1"
        .Range("AB2", .Range("AB2").End(xlDown)).name = "IB_Adress2"
        .Range("D2", .Range("D2").End(xlDown)).name = "ColD"
        .Range("E2", .Range("E2").End(xlDown)).name = "ColE"
        .Range("F2", .Range("F2").End(xlDown)).name = "ColF"
        .Range("G2", .Range("G2").End(xlDown)).name = "ColG"
        .Range("H2", .Range("H2").End(xlDown)).name = "ColH"
        .Range("I2", .Range("I2").End(xlDown)).name = "ColI"
        .Range("J2", .Range("J2").End(xlDown)).name = "ColJ"
        .Range("K2", .Range("K2").End(xlDown)).name = "ColK"
'        .Range("K2", .Range("K2").End(xlDown)).name = "ColL"
        .Range("M2", .Range("M2").End(xlDown)).name = "ColM"
        .Range("N2", .Range("N2").End(xlDown)).name = "ColN"
        .Range("O2", .Range("O2").End(xlDown)).name = "ColO"
        .Range("P2", .Range("P2").End(xlDown)).name = "ColP"
        .Range("Q2", .Range("Q2").End(xlDown)).name = "ColQ"
        .Range("R2", .Range("R2").End(xlDown)).name = "ColR"
        .Range("S2", .Range("S2").End(xlDown)).name = "ColS"
        .Range("T2", .Range("T2").End(xlDown)).name = "ColT"
'        .Range("U2", .Range("U2").End(xlDown)).name = "ColU"
'        .Range("V2", .Range("V2").End(xlDown)).name = "ColV"
'        .Range("W2", .Range("W2").End(xlDown)).name = "ColW"
'        .Range("X2", .Range("X2").End(xlDown)).name = "ColX"
'        .Range("Y2", .Range("Y2").End(xlDown)).name = "ColY"
'        .Range("Z2", .Range("Z2").End(xlDown)).name = "ColZ"


    End With
End Sub


Sub AAA_Fill_Temp()
    Dim bottom As String
    bottom = Range("A9").End(xlDown).Address
    bottom = Replace(bottom, "$A$", "")
    'Sheets("Test").Range("E4:E" & bottom).Formula = "=IFERROR(LOWER(INDEX(IB_Information, MATCH(C4, IB_Accounts,0),2)), ""Missing"")"
    'Sheets("Test").Range("F4:F" & bottom).Formula = "=IFERROR(PROPER((INDEX(IB_Information,MATCH(C4,IB_Accounts,0),1))), ""Missing"")"
'    >> Fills The Name and Address1&2
    Sheets("Test").Range("A11:A11").Formula = "=IFERROR(PROPER(INDEX(IB_Information, MATCH($A$9, IB_Accounts,0),1)), ""Missing"")"
    Sheets("Test").Range("A12:A12").Formula = "=IFERROR(UPPER(INDEX(IB_Adress, MATCH($A$9, IB_Accounts,0),1)), ""Missing"")"
    Sheets("Test").Range("A13:A13").Formula = "=IFERROR(UPPER(INDEX(IB_Adress2, MATCH($A$9, IB_Accounts,0),1)), ""Missing"")"
'    >> Fills The Columns D-K
    Sheets("Test").Range("B22:B22").Formula = "=IFERROR((INDEX(ColD, MATCH($A$9, IB_Accounts,0),1)), "" - "")"
    Sheets("Test").Range("B23:B23").Formula = "=IFERROR((INDEX(ColE, MATCH($A$9, IB_Accounts,0),1)), "" - "")"
    Sheets("Test").Range("B24:B24").Formula = "=IFERROR((INDEX(ColF, MATCH($A$9, IB_Accounts,0),1)), "" - "")"
    Sheets("Test").Range("B25:B25").Formula = "=IFERROR((INDEX(ColG, MATCH($A$9, IB_Accounts,0),1)), "" - "")"
    Sheets("Test").Range("B26:B26").Formula = "=IFERROR((INDEX(ColH, MATCH($A$9, IB_Accounts,0),1)), "" - "")"
    Sheets("Test").Range("B27:B27").Formula = "=IFERROR((INDEX(ColI, MATCH($A$9, IB_Accounts,0),1)), "" - "")"
    Sheets("Test").Range("B28:B28").Formula = "=IFERROR((INDEX(ColJ, MATCH($A$9, IB_Accounts,0),1)), "" - "")"
    Sheets("Test").Range("B29:B29").Formula = "=IFERROR((INDEX(ColK, MATCH($A$9, IB_Accounts,0),1)), "" - "")"
'    Sheets("Test").Range("B22:B22").Formula = "=IFERROR((INDEX(ColL, MATCH($A$9, IB_Accounts,0),1)), "" - "")"

'    >> Fills The Columns M-Z
    Sheets("Test").Range("C22:C22").Formula = "=IFERROR((INDEX(ColM, MATCH($A$9, IB_Accounts,0),1)), "" - "")"
    Sheets("Test").Range("C23:C23").Formula = "=IFERROR((INDEX(ColN, MATCH($A$9, IB_Accounts,0),1)), "" - "")"
    Sheets("Test").Range("C24:C24").Formula = "=IFERROR((INDEX(ColO, MATCH($A$9, IB_Accounts,0),1)), "" - "")"
    Sheets("Test").Range("C25:C25").Formula = "=IFERROR((INDEX(ColP, MATCH($A$9, IB_Accounts,0),1)), "" - "")"
    Sheets("Test").Range("C26:C26").Formula = "=IFERROR((INDEX(ColQ, MATCH($A$9, IB_Accounts,0),1)), "" - "")"
    Sheets("Test").Range("C27:C27").Formula = "=IFERROR((INDEX(ColR, MATCH($A$9, IB_Accounts,0),1)), "" - "")"
    Sheets("Test").Range("C28:C28").Formula = "=IFERROR((INDEX(ColS, MATCH($A$9, IB_Accounts,0),1)), "" - "")"
    Sheets("Test").Range("C29:C29").Formula = "=IFERROR((INDEX(ColT, MATCH($A$9, IB_Accounts,0),1)), "" - "")"
    Range("B4").Select
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

(A9 is where I filled the IB number so that every time A9 is different, it populates the rest of the chart/template)

3) Then move to the next IB# while generating new sheets.
Not sure how to mix the generating the multiple IB# sheets and filling the template

4) Then save them all in a folder that contains the same name as the file as was working on.

Sub SaveVisibleShtsAsBook()
    Dim Sheet As Worksheet, MyFilePath As String, w As Long
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    On Error Resume Next '<< a folder exists
    'define the workbook
    With ThisWorkbook
        MyFilePath = Left(.FullName, InStrRev(.FullName, ".") - 1)
        MkDir MyFilePath '<< create a folder
        For w = 1 To .Worksheets.Count
            'check if worksheet is visible
            If .Worksheets(w).Visible = xlSheetVisible Then
                .Worksheets(w).Copy   'create new active workbook with copy of worksheet
                With ActiveWorkbook
                    .Worksheets(1).Cells(1, "A").Select
                     'save book in this folder. Use FileFormat argument instead of adding .XLSX
                    .SaveAs Filename:=MyFilePath & "\" & .Worksheets(1).Name _
                    & " - 2020 ", FileFormat:=xlOpenXMLWorkbook '<<Change Year when needed
                    'close saving changes
                    .Close SaveChanges:=True
                End With
            End If
        Next w
        End With
    Sheet1.Activate
End Sub

Thanks for the help!

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.