删除excel vba宏中的数据库连接

时间：2016-04-05 13:11:01

标签： excel vba excel-vba

因此，我设法使用模板创建多个保存为.xlsx文件的Excel文件，以确保宏不会保存为新创建的文件的一部分。 然而，我现在遇到了在宏中刷新的数据库连接的问题。如果我删除这些文件，则以下文件创建时将创建原始文件中的数据，因为连接字符串已被破坏。看起来这个过程的工作方式是下一个文件是从前一个文件创建的，而不是从模板创建的 - 一种斗式旅行方法。现在我知道人们会问我尝试了什么，但是花了几个星期（当我有机会被抢走时）才能达到这一点，我不能再进一步了。请伙计们，我已经用Google搜索并尝试了一切，但它超出了我的范围。 请你可以帮忙吗？我已经在我的代码中包含了删除连接的部分 - 但正如我所说，这似乎不是正确的方法。 谢谢

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

1 个答案:

答案 0 :(得分：1)

我认为以下内容会解决您的问题。另见您对问题的评论。

子例程Button3_clieck()位于当前工作簿中。该工作簿还具有创建其他工作簿的信息单元格。

您有一个单独的工作簿，其中包含您用作模板的工作表（使用宏从当前工作簿创建它）。它在每个单元格的while循环中打开：

Set wkbTemplate = Workbooks.Open(filename:="MyTemplate.xlsm")

格式化工作表后，将其保存在您的名下，然后将其关闭。您将在while循环的下一次迭代中再次打开它。

保存两个工作簿后，再次重新打开它们以删除连接。然后你关闭它们。

现在您处理下一个单元格。

以下（伪）代码说明了这一点。我无法检查代码，因此可能会出现一些错误。

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
相关问题
最新问题