Excel VBA宏可创建多个无宏的工作簿

Question

I asked this question a few weeks ago but I have not had a response - I am really stuck. The reason I have to do this is to try resolve a mess a contractor left - I normally have very little contact with VBA so this is too complex for my basic knowledge. I want the macro to do the following:

1. Loop through a column of selected rows on a sheet in my workbook to get the names for each of the new workbooks to be created (I have this working)
2. Refresh all data within the newly created workbook (I have this working)
3. copy/paste values on one of the sheets in newly created book (not yet but I guess this is straight-forward)
4. delete two sheets in the workbook (I have this working)
5. delete the macro in the new workbook (help from here on!!)
6. save and close newly created workbook
7. Move onto next workbook to be created
8. Once all are finished, return to template or close template - either or.

here is the code I already have:

Sub Button3_Click()

Dim MyCell As Range, MyRange As Range
Dim currentSheet As Excel.Worksheet
Dim LR As Long
Set currentSheet = ActiveSheet

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

    ActiveWorkbook.RefreshAll
    ActiveWorkbook.SaveAs Filename:="P:\Informatics\S&L scorecards\Clinical Scorecard Template\test\" & MyCell.Value & ".xls"

' code here to delete worksheets and delete macro?

    Next MyCell 
End Sub

Thanks in advance

Answer 1

The Simplest way to Remove the Macros from a Workbook template is to .SaveAs a .xlsx workbook. xlsx workbooks do not support macros and they are lost on save. I'm not sure if they are recoverable from this state so if there are security issues with the code getting out this may not be an effective method for your needs.

Below is a quick Sudo Code to help get you started.

'For row 1 to x of RangeOfNewWorkbookNames
'Workbooks.open Template
'Workbooks.Sheets().Copy Paste
'Workbooks.SaveAs
'Workbooks.close
'Next row

Answer 2

Here be my answer... although it opened another can of worms I'll open in another question to avoid confusion:

Sub Button3_Click()

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


     'some formatting crud goes here

        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
           Dim wkb As Workbook
        Set wkb = Workbooks.Open(Filename:="P:\Informatics\S&L scorecards\02 Clinical Scorecards\" & Format(Now(), "yyyy") & "\" & "CNST - " & MyCell.Value & " " & Format(Now(), "dd-mmm-yyyy") & ".xlsx")


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


       ActiveWorkbook.Close

End Sub

Answer 3

The Complete answer for anyone who needs it thank you to the wonderful Paul Ogilvie for your help. This uses a template to create as many workbooks as you select from a list (in this case I created a table with a complete list of available values and the user selects all the ones they want) and the template creates all the workbooks named as per the list (and in my case creates another copy with a different name - for mailing) refreshes all the data based on the current row from the chosen list and then saves it as a .xlsx to remove the macro and then removes the links to the sql database where the information originally came from - the means the user gets a macro and connection-free workbook with only the data they need:

Sub Button3_Click()

    Dim MyCell As Range, MyRange As Range
    Dim LR As Long
    Dim xConnect As Object
    Dim wkb As Workbook
    Dim wkbTemplate As Workbook     ' this is the opened template
    Dim wkbThis As Workbook         ' this is a reference to this workbook

    Application.ScreenUpdating = False

    Dim basepath
    basepath = "P:\Informatics\S&L scorecards\02 Clinical Scorecards\"
    Dim TempPath
    TempPath = "P:\Informatics\S&L scorecards\01 Scorecard Template\01 Clinical\"

    If Dir(basepath & Format(Now(), "yyyy") & "\", vbDirectory) = "" Then
        MkDir Path:=basepath & Format(Now(), "yyyy") & "\"
    End If

    If Dir(basepath & Format(Now(), "yyyy") & "\Trust Code Files\", vbDirectory) = "" Then
        MkDir Path:=basepath & Format(Now(), "yyyy") & "\Trust Code Files\"
    End If

    Set wkbThis = ActiveWorkbook    ' to prevent any confusion, we use abolute workbook references
    LR = wkbThis.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

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

    For Each MyCell In MyRange

        Set wkbTemplate = Workbooks.Open(Filename:=TempPath & "MyTemplate.xlsm")   ' re-open the template for each cell

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

        Application.DisplayAlerts = False
        wkbTemplate.RefreshAll


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

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

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

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

        wkbTemplate.Saved = True
        wkbTemplate.Sheets("Members").Visible = False
        wkbTemplate.Sheets("Front Sheet").Visible = False
        wkbTemplate.Worksheets("Graphs Red Zone").PageSetup.CenterFooter = wkbTemplate.Worksheets("Overview Score Card").Range("A4:F4").Value
        wkbTemplate.Worksheets("Graphs Blue Zone").PageSetup.CenterFooter = wkbTemplate.Worksheets("Overview Score Card").Range("A4:F4").Value
        wkbTemplate.Worksheets("Graphs Yellow Zone").PageSetup.CenterFooter = wkbTemplate.Worksheets("Overview Score Card").Range("A4:F4").Value
        wkbTemplate.Worksheets("Graphs Green Zone").PageSetup.CenterFooter = wkbTemplate.Worksheets("Overview Score Card").Range("A4:F4").Value

        ' this deletes connections
        For Each xConnect In wkbTemplate.Connections
            If xConnect.Name <> "ThisWorkbookDataModel" Then xConnect.Delete
        Next xConnect




        wkbTemplate.SaveAs Filename:=basepath & Format(Now(), "yyyy") & "\" & "CNST - " & MyCell.Value & " " & Format(Now(), "dd-mmm-yyyy") & ".xlsx", FileFormat:=xlOpenXMLWorkbook
        wkbTemplate.SaveAs Filename:=basepath & Format(Now(), "yyyy") & "\Trust Code Files\" & MyCell.Offset(, 5).Value & ".xlsx", FileFormat:=xlOpenXMLWorkbook
        wkbTemplate.Close SaveChanges:=False



        Application.DisplayAlerts = True
    Next MyCell

    'ActiveWorkbook.Close
    Application.ScreenUpdating = True

End Sub