Creating multiple workbooks from a template

[AJCT5]

Hi Everyone

I have a problem that I am not able to solve as my VBA is not good when having to do more that changing the contents of a workbook! I will post the code I am using so far below but the functionality I require is as follows:

2. Open a template (has links to a number of SQL tables, one which refreshes upon opening the file which then populates a table. This table provides the user with a list of option to choose one or multiple items from.
3. Press a button that creates a range from the user selection,
4. Loop through each member of the range to use the value to refresh the rest of the SQL table connections ,
5. save the file as a .xlsx (so there is no macro attached)
6. Remove the database connections
7. Repeat process for every selection made by the user.

Here is my code:

Sub Button3_Click()



Application.ScreenUpdating = False
Dim MyCell As Range, MyRange As Range


Dim LR As Long

If Dir("P:\Informatics\S&L scorecards\02 Clinical Scorecards\" & Format(Now(), "yyyy") & "\", vbDirectory) = "" Then
    MkDir Path:="P:\Informatics\S&L scorecards\02 Clinical Scorecards\" & Format(Now(), "yyyy") & "\"
    
End If

If Dir("P:\Informatics\S&L scorecards\02 Clinical Scorecards\" & Format(Now(), "yyyy") & "\Trust Code Files\", vbDirectory) = "" Then
    MkDir Path:="P:\Informatics\S&L scorecards\02 Clinical Scorecards\" & Format(Now(), "yyyy") & "\Trust Code Files\"
    
End If

 LR = Range("A" & Rows.Count).End(xlUp).Row


'this gets the values for workbook names
Set MyRange = Range("A2:A" & LR).SpecialCells(xlCellTypeVisible)


For Each MyCell In MyRange


  'this populates a cell with the name in the range that the workbook then references for refreshing an MS query
    Worksheets("Front Sheet").Cells(5, 5) = MyCell.Value
    Worksheets("Front Sheet").Cells(5, 6) = MyCell.Offset(, 1).Value
    Worksheets("Front Sheet").Cells(5, 7) = MyCell.Offset(, 2).Value
    Worksheets("Front Sheet").Cells(5, 8) = MyCell.Offset(, 3).Value
    Worksheets("Front Sheet").Cells(5, 9) = MyCell.Offset(, 4).Value
    
        Application.DisplayAlerts = False
        ActiveWorkbook.RefreshAll


        ActiveWorkbook.Sheets("Speciality Score Card").Range("B7:D16").Interior.Color = RGB(251, 222, 5) 'light yellow
        ActiveWorkbook.Sheets("Speciality Score Card").Range("B6:D6").Interior.Color = RGB(255, 192, 0) ' dark yellow

        ActiveWorkbook.Sheets("Speciality Score Card").Range("E6:E6").Interior.Color = RGB(231, 25, 25) 'dark red
        ActiveWorkbook.Sheets("Speciality Score Card").Range("E7:G16").Interior.Color = RGB(255, 0, 0) 'light red

        ActiveWorkbook.Sheets("Speciality Score Card").Range("B17:D17").Interior.Color = RGB(0, 102, 0) 'dark green
        ActiveWorkbook.Sheets("Speciality Score Card").Range("B18:D32").Interior.Color = RGB(0, 176, 80) 'light green

        
        ActiveWorkbook.Sheets("Speciality Score Card").Range("E18:G32").Interior.Color = RGB(0, 88, 154) 'light blue
        ActiveWorkbook.Sheets("Speciality Score Card").PivotTables("PivotTable3").DataBodyRange.Interior.Color = RGB(0, 88, 154) 'light blue
        ActiveWorkbook.Sheets("Speciality Score Card").PivotTables("PivotTable3").RowRange.Interior.Color = RGB(0, 88, 154) 'light blue
        ActiveWorkbook.Sheets("Speciality Score Card").Range("E17:G17").Interior.Color = RGB(0, 32, 96) 'dark blue
'       ActiveWorkbook.Sheets("Overview Score Card").Range("C1").Copy
'       ActiveWorkbook.Sheets("Overview Score Card").Range("C1").PasteSpecial (xlPasteValues)

        ActiveWorkbook.Saved = True
        ActiveWorkbook.Sheets("Members").Visible = False
        ActiveWorkbook.Sheets("Front Sheet").Visible = False
         Worksheets("Graphs Red Zone").PageSetup.CenterFooter = Worksheets("Overview Score Card").Range("A4:F4").Value
        Worksheets("Graphs Blue Zone").PageSetup.CenterFooter = Worksheets("Overview Score Card").Range("A4:F4").Value
        Worksheets("Graphs Yellow Zone").PageSetup.CenterFooter = Worksheets("Overview Score Card").Range("A4:F4").Value
        Worksheets("Graphs Green Zone").PageSetup.CenterFooter = Worksheets("Overview Score Card").Range("A4:F4").Value
    
        ActiveWorkbook.SaveAs Filename:="P:\Informatics\S&L scorecards\02 Clinical Scorecards\" & Format(Now(), "yyyy") & "\" & "CNST - " & MyCell.Value & " " & Format(Now(), "dd-mmm-yyyy") & ".xlsx", FileFormat:=xlOpenXMLWorkbook
        ActiveWorkbook.SaveAs Filename:="P:\Informatics\S&L scorecards\02 Clinical Scorecards\" & Format(Now(), "yyyy") & "\Trust Code Files\" & MyCell.Offset(, 5).Value & ".xlsx", FileFormat:=xlOpenXMLWorkbook
      

' code here to delete worksheets and delete macro?
  Application.DisplayAlerts = True
    Next MyCell
     


       ActiveWorkbook.Close
Application.ScreenUpdating = True
End Sub

So currently I can do all but number 5. I am guessing that this is because the macro is using the last created file to create another one instead of the files being created from the original template, so if I delete the connections using code to loop through the connections like this:

Dim xConnect As Object

 For Each xConnect In activeworkbook.Connections
                If xConnect.Name <> "ThisWorkbookDataModel" Then xConnect.Delete
        Next xConnect

I end up with the same data for every workbook because the connection was killed in the first iteration.

My skills are such that I am stuck in the chicken/egg scenario.


I would be so grateful for any help I get.

Kind regards


AJCT5