1. ホーム
  2. 質問と答え
  3. excel vbaマクロでデータベース接続を削除する

excel vbaマクロでデータベース接続を削除する

2016-04-05 38 views
0

テンプレートを使用して、.xlsxファイルとして保存された複数のExcelファイルを作成して、マクロが新しく作成されたファイルの一部として保存されないようにしました。 しかし、、私は今マクロ内でリフレッシュされるデータベース接続の問題があります。これらを削除すると、次のファイルを作成すると、接続文字列が破損したために作成された元のファイルのデータが作成されます。このプロセスが機能する方法は、テンプレートからではなく、以前のファイルから作成されたもので、バケット旅団アプローチのようなものです。今私は人々が私に何を試してきたのか聞いてくれることを知っていますが、この時点までに数週間（私がチャンスを得た時に奪取された）の時間がかかりました。みんな、私はgoogledとすべての地獄を試してみましたが、それは私を超えています。 お手伝いできますか？私は自分のコードに接続を削除する部分を含めましたが、私が言うように、これは正しいアプローチではありません。 ありがとうございますexcel vbaマクロでデータベース接続を削除する

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

出典

2016-04-05 AJCT

+0

注意。それは間違っているようだ。そして、各セルの書式設定後にブックを保存します。 –

+0

"_次のファイルはテンプレートからではなく、前のファイルから作成されます。"はい、アクティブなワークブックを再利用し続けるからです。 –

+0

@PaulこんにちはPaul - それがなぜそれを行うのかを明確にしてくれてありがとう - どうして私はそれを毎回テンプレートに戻すのですか？ – AJCT

答えて

1

私はあなたの問題を嘆くと思います。あなたの質問へのコメントも見てください。

サブルーチンButton3_clieck()は現在のワークブックにあります。そのワークブックには、他のワークブックを作成するための情報が入ったセルもあります。

テンプレートとして使用するシート（マクロを使用して現在のブックから作成）とは別のワークブックがあります。各セルのwhileループで開きます。

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

シートをフォーマットした後、名前を付けて保存して閉じます。 whileループの次の反復で再び開きます。

2つのブックを保存した後、もう一度それらを開いて接続を削除します。その後、それらを閉じます。

次のセルを処理します。

次の（疑似）コードはこれを示しています。私はコードをチェックすることができなかったので、いくつかのエラーがあるかもしれません。あなたは `wkb`と` wkb2`を開いているMyRange` `で各cell_を_for

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

出典

2016-04-06 14:37:44

+0

ああ！あなたに感謝します - これは絶対的な治療法です！私が行った唯一の変更は、コードが以下の接続を削除することです： – AJCT

0 
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

出典

2016-04-08 09:25:26 AJCT

+0

はい、それは接続を削除するより良い場所です。 –

関連する問題

 関連する問題