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

时间：2016-03-21 14:19:39

标签： excel vba excel-vba macros

几周前我问过这个问题，但我没有回复 - 我真的被困了。我必须这样做的原因是尝试解决一个承包商留下的混乱 - 我通常与VBA很少接触，所以这对我的基本知识来说太复杂了。我希望宏执行以下操作：

  1. 遍历工作簿中工作表中选定行的列，以获取要创建的每个新工作簿的名称（我有此工作）
  2. 刷新新创建的工作簿中的所有数据（我有这个工作）
  3. 在新创建的书籍中的一张纸上复制/粘贴值（尚未，但我想这很简单）
  4. 删除工作簿中的两个工作表（我有这个工作）
  5. 删除新工作簿中的宏（从此处获取帮助!!）
  6. 保存并关闭新创建的工作簿
  7. 转到要创建的下一个工作簿
  8. 完成所有操作后，返回模板或关闭模板 - 或者。

    9. 这是我已有的代码：

    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

    提前致谢

3 个答案:

答案 0 :(得分：0)

从工作簿模板中删除宏的最简单方法是on_submit: "window.open("https://www.google.com","_self");" .SaveAs工作簿。 .xlsx工作簿不支持宏，并且在保存时会丢失。我不确定它们是否可从此状态恢复，因此如果代码出现安全问题，这可能不是满足您需求的有效方法。

以下是一个快速的Sudo代码，可帮助您入门。

xlsx

答案 1 :(得分：0)

这是我的回答......虽然它打开了另一种蠕虫，但我会在另一个问题中打开以避免混淆：

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

答案 2 :(得分：0)

对于任何需要它的人来说，完整的答案都会感谢你提供的Paul Ogilvie精彩的帮助。这使用模板创建从列表中选择的工作簿（在本例中，我创建了一个包含可用值的完整列表的表，用户选择了他们想要的所有工作簿），模板创建了所有按工作簿命名的工作簿列表（在我的情况下创建另一个具有不同名称的副本 - 用于邮件）根据所选列表中的当前行刷新所有数据，然后将其保存为.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
相关问题
最新问题