在excel vbamacros中删除数据库连接
所以我设法使用一个模板创build多个Excel文件保存为一个.xlsx文件，以确保macros不保存为新创build的文件的一部分。 但是 ，我现在有在macros内刷新数据库连接的问题。 如果我删除这些文件，下面的文件将会创build连接string被破坏时创build的原始文件中的数据。 看起来这个过程的工作方式是下一个文件是从前一个创build的，而不是从模板创build – 一种桶式旅的方法。 现在我知道人们会问我尝试了什么，但是我已经花了几个星期（当我有机会的时候被抢走了）来达到这个目的，我不能再进一步了。 请大家，我已经search了一切，但它超出了我。 请你帮忙吗？ 我已经在我的代码中join了删除连接的部分 – 但正如我所说，这看起来并不正确。 谢谢
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) Dim xConnect As Object 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 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") Dim wkb2 As Workbook Set wkb2 = Workbooks.Open(Filename:="P:\Informatics\S&L scorecards\02 Clinical Scorecards\" & Format(Now(), "yyyy") & "\Trust Code Files\" & MyCell.Offset(, 5).Value & ".xlsx") Application.DisplayAlerts = True Next MyCell ' this deletes connections For Each xConnect In wkb.Connections If xConnect.Name <> "ThisWorkbookDataModel" Then xConnect.Delete Next xConnect For Each xConnect In wkb2.Connections If xConnect.Name <> "ThisWorkbookDataModel" Then xConnect.Delete Next xConnect ActiveWorkbook.Close End Sub
我认为以下将解决您的问题。 另请参阅您的问题的意见。
子程序Button3_clieck()在当前工作簿中。 该工作簿还具有用于创build其他工作簿的信息单元。
你有一个单独的工作簿，用作模板的工作表（使用macros从当前工作簿中创build）。 它在每个单元的while循环中打开：
Set wkbTemplate = Workbooks.Open(filename:="MyTemplate.xlsm")
格式化纸张后，将其保存在名称下，然后closures它。 您将在while循环的下一次迭代中再次打开它。
保存两个工作簿后，再次打开它们以删除连接。 然后你closures它们。
现在你处理下一个单元格。
以下（伪）代码说明了这一点。 我无法检查代码，所以可能会出现一些错误。
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 Dim basepath basepath = "P:\Informatics\S&L scorecards\02 Clinical Scorecards\" 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:="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 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 ' this deletes connections Set wkb = Workbooks.Open(filename:=basepath & Format(Now(), "yyyy") & "\" & "CNST - " & MyCell.Value & " " & Format(Now(), "dd-mmm-yyyy") & ".xlsx") For Each xConnect In wkb.Connections If xConnect.Name <> "ThisWorkbookDataModel" Then xConnect.Delete Next xConnect wkb.Close Set wkb = Workbooks.Open(filename:=basepath & Format(Now(), "yyyy") & "\Trust Code Files\" & MyCell.Offset(, 5).Value & ".xlsx") For Each xConnect In wkb.Connections If xConnect.Name <> "ThisWorkbookDataModel" Then xConnect.Delete Next xConnect wkb.Close Application.DisplayAlerts = True Next MyCell 'ActiveWorkbook.Close End Sub
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