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

几个星期前我问了这个问题，但我没有得到回应——我真的被卡住了。我必须这样做的原因是试图解决一个承包商留下的烂摊子-我通常很少与VBA接触，所以这对我的基本知识来说太复杂了。我希望宏执行以下操作：

在我的工作簿中的工作表上循环一列选定的行，以获取要创建的每个新工作簿的名称（我有此工作表）

刷新新创建工作簿中的所有数据（我有此工作表）

将值复制/粘贴到新创建的书本中的一张纸上（还没有，但我想这是直截了当的）

删除工作簿中的两张工作表（我有此工作表）

删除新工作簿中的宏（从此处开始提供帮助！！）

保存并关闭新创建的工作簿

转到要创建的下一个工作簿

完成所有操作后，返回模板或关闭模板-或

以下是我已有的代码：

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

---

提前感谢

从工作簿模板中删除宏的最简单方法是

.SaveAs

a

.xlsx

工作簿

xlsx

工作簿不支持宏，保存时会丢失宏。我不确定它们是否可以从此状态恢复，因此如果代码传出时存在安全问题，这可能不是满足您需要的有效方法

下面是一个快速的Sudo代码，可以帮助您开始

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

---

这是我的答案。。。虽然它打开了另一个蠕虫罐头，但为了避免混淆，我将在另一个问题中打开：

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

---

所有需要它的人的完整答案感谢你的帮助。这使用一个模板创建从列表中选择的任意多个工作簿（在本例中，我创建了一个包含完整可用值列表的表，用户选择了他们想要的所有值），模板创建了根据列表命名的所有工作簿（在本例中，创建了另一个具有不同名称的副本-用于邮寄）根据所选列表中的当前行刷新所有数据，然后将其另存为

.xlsx

以删除宏，然后删除指向原始信息来源的sql数据库的链接-这意味着用户将获得一个宏和无连接工作簿，其中只包含他们需要的数据：

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

子按钮3\u单击（）
Dim MyCell作为范围，MyRange作为范围
变暗LR为长
作为对象的Dim xConnect
将wkb设置为工作簿
Dim wkbTemplate As工作簿“这是打开的模板
Dim wkbThis As工作簿“这是对此工作簿的引用
Application.ScreenUpdating=False
暗基径
basepath=“P:\Informatics\S&L记分卡\02临床记分卡”
暗温路径
TempPath=“P:\Informatics\S&L记分卡\01记分卡模板\01临床\”
如果Dir（basepath和Format（Now（），“yyyy”）和“\”，vbDirectory）=“”，则
MkDir路径：=basepath和Format（Now（），“yyyy”）和“\”
如果结束
如果Dir（basepath和Format（Now（），“yyyy”）和“\Trust Code Files\”，vbDirectory）=“”，则
MkDir路径：=basepath和Format（Now（），“yyyy”）&“\Trust Code Files”
如果结束
设置wkbThis=ActiveWorkbook'为避免任何混淆，我们使用单独的工作簿引用
LR=wkbThis.ActiveSheet.Range（“A”&Rows.Count）.End（xlUp）.Row
'这将获取工作簿名称的值
设置MyRange=wkbThis.ActiveSheet.Range（“A2:A”&LR）.SpecialCells（xlCellTypeVisible）
对于MyRange中的每个MyCell
设置wkbTemplate=Workbooks.Open（文件名：=TempPath&“MyTemplate.xlsm”）'重新打开每个单元格的模板
'这将使用工作簿刷新MS查询时引用的范围内的名称填充单元格
wkbTemplate.工作表（“前页”）.单元格（5,5）=MyCell.值
wkbTemplate.工作表（“前页”）.单元格（5,6）=MyCell.偏移量（，1）.值
wkbTemplate.工作表（“前页”）.单元格（5,7）=MyCell.偏移量（，2）.值
wkbTemplate.工作表（“前页”）.单元格（5,8）=MyCell.偏移量（，3）.值
wkbTemplate.工作表（“前页”）.单元格（5,9）=MyCell.偏移量（，4）.值
Application.DisplayAlerts=False
wkbTemplate.RefreshAll
wkbTemplate.Sheets（“专业记分卡”）。范围（“B7:D16”）。内饰。颜色=RGB（251，222，5）“浅黄色”
wkbTemplate.Sheets（“专业记分卡”）.Range（“B6:D6”）.Interior.Color=RGB（255，192，0）”深黄色
wkbTemplate.Sheets（“专业记分卡”）.范围（“E6:E6”）.内饰.Color=RGB（231,25,25）“深红色
wkbTemplate.Sheets（“专业记分卡”）.Range（“E7:G16”）.Interior.Color=RGB（255,0,0）”浅红色
wkbTemplate.Sheets（“专业记分卡”）.Range（“B17:D17”）.Interior.Color=RGB（0,102,0）”深绿色
wkbTemplate.Sheets（“专业记分卡”）。范围（“B18:D32”）。内饰。颜色=RGB（0，176，80）'浅绿色
wkbTemplate.Sheets（“专业记分卡”）.Range（“E18:G32”）.Interior.Color=RGB（0,88,154）浅蓝色
wkbTemplate.Sheets（“专业记分卡”）。数据透视表（“数据透视表3”）。DatagodyRange.Interior.Color=RGB（0,88,154）'浅蓝色
wkbTemplate.Sheets（“专业记分卡”）。数据透视表（“数据透视表3”）。RowRange.Interior.Color=RGB（0，88，154）浅蓝色
wkbTemplate.Sheets（“专业记分卡”）.Range（“E17:G17”）.Interior.Color=RGB（0,32,96）”深蓝色
wkbTemplate.Sheets（“总览记分卡”）.范围（“C1”）.副本
wkbTemplate.Sheets（“总览记分卡”）.Range（“C1”）.PasteSpecial（XLPasteValue）
wkbTemplate.Saved=True
wkbTemplate.Sheets（“成员”）.Visible=False
wkbTemplate.Sheets（“前页”）。可见=假
wkbTemplate.Worksheets（“红色区域图形”）.PageSetup.CenterFooter=wkbTemplate.Worksheets（“总览记分卡”）.Range（“A4:F4”）.Value
wkbTemplate.Worksheets（“蓝色区域图形”）.PageSetup.CenterFooter=wkbTemplate.Worksheets（“概述”）