提取Excel数据连接命令文本
我有大约300个具有一个或多个“Microsoft Query”数据连接的Excel文件，该连接从SQL服务器中提取数据。 我想清点，然后摆脱重复和旧版本。
在每个查询的数据连接属性中都有一个“命令文本”框，其中包含一个Select语句，该语句显示了它在SQL服务器上访问的表和视图。 我想从所有的文件中提取这个文本，以便我可以评估它们。
我已经使用VBA来改变命令文本，所以我不认为这将是很难做到这一点。 但是我对VBA的了解是相当有限的，尽pipe有很多研究，我还没有find起点：如何将命令文本输出到文本文件中。 之后，如果文件中有多个查询，应该能够弄清楚如何修改它来一次拉取信息。
我发现的一件事是，单单导出命令文本可能是不可能的。 当我试图使用导出到ODCfunction，它看起来像所有的连接属性都包括在内。 这很好，但我从来没有取得任何成功的工作。
Application.ActiveWorkbook.ODBCConnection.SaveAsODC ("ODCFile")
提前致谢
这里的主要模块循环遍历您指定的文件夹中的所有Excel工作簿，并为每个工作表中的每个ListObject列出CommandText和SourceConnectionFile。 ListObjects（表）不一定有数据连接，所以我通过检查ListObject是否有一个应该表示它有连接的QueryTable来testing。 请注意，这仅在Excel 2007中才是真实的 – 在2003年，QueryTables站在了自己的angular度。
有两个函数：一个testing一个QueryTable，正如我在这篇文章中所讨论的 ; 和一个获取所有的Excel工作簿在一个文件夹。
输出将打印到与此代码运行的工作簿位于同一文件夹中的文本文件。
我testing了这一点，它的工作，但我没有努力，使其失败：
Sub ListCommandTexts() Dim WorkbooksToCheck() As String Dim WbIndex As Long Dim wb As Excel.Workbook Dim ws As Excel.Worksheet Dim lo As Excel.ListObject Dim qt As Excel.QueryTable On Error GoTo Exit_Point Application.ScreenUpdating = False Application.DisplayAlerts = False Application.EnableEvents = False 'your log file will be in this workbook's folder Open ThisWorkbook.Path & Application.PathSeparator & "CommandTextLog.txt" For Append As #1 'gets all workbook names in folder '(see function below) WorkbooksToCheck() = GetWorkbookNames("c:\Test\") 'modify for your folder For WbIndex = LBound(WorkbooksToCheck) To UBound(WorkbooksToCheck) Set wb = Workbooks.Open(Filename:=WorkbooksToCheck(WbIndex), UpdateLinks:=False) For Each ws In wb.Worksheets For Each lo In ws.ListObjects 'if listobject has no querytable, just slide on by '(see function below) Set qt = GetListObjectQueryTable(lo) If Not qt Is Nothing Then Print #1, wb.Name & "; " & ws.Name & "; " & lo.Name & "; " & qt.CommandText & "; " & qt.SourceConnectionFile End If Next lo Next ws wb.Close savechanges:=False Next WbIndex Exit_Point: Close #1 Application.ScreenUpdating = True Application.DisplayAlerts = True Application.EnableEvents = True Exit Sub err_handler: Debug.Print Err.Number & "; " & Err.Description GoTo Exit_Point End Sub Function GetWorkbookNames(strSourceFolder As String) As String() Dim fso As Object 'Scripting.FileSystemObject Dim SourceFolder As Object Dim FileItem As Object Dim strWorkbookNames() As String Dim i As Long Set fso = CreateObject("Scripting.FileSystemObject") Set SourceFolder = fso.GetFolder(strSourceFolder) i = 0 With SourceFolder For Each FileItem In SourceFolder.Files If FileItem.Type = "Microsoft Excel Worksheet" Or FileItem.Type = "Microsoft Excel 97-2003 Worksheet" Then i = i + 1 ReDim Preserve strWorkbookNames(1 To i) strWorkbookNames(i) = FileItem.Path End If Next FileItem End With GetWorkbookNames = strWorkbookNames() Set SourceFolder = Nothing Set fso = Nothing End Function Function GetListObjectQueryTable(lo As Excel.ListObject) As Excel.QueryTable On Error Resume Next Set GetListObjectQueryTable = lo.QueryTable End Function
编辑 – 使用Excel 2003，其中QueryTables是Worksheet对象的直接成员。 请注意，这是未经testing，从内存。 这很接近，我确定，如果需要的话，稍微查看Excel 2003 QueryTable对象将会有所帮助。
replace这个：
For Each ws In wb.Worksheets For Each lo In ws.ListObjects 'if listobject has no querytable, just slide on by '(see function below) Set qt = GetListObjectQueryTable(lo) If Not qt Is Nothing Then Print #1, wb.Name & "; " & ws.Name & "; " & lo.Name & "; " & qt.CommandText & "; " & qt.SourceConnectionFile End If Next lo Next ws
… 有了这个：
For Each ws In wb.Worksheets For Each qt In ws.QueryTables Print #1, wb.Name & "; " & ws.Name & "; " & qt.CommandText & "; " & qt.SourceConnectionFile Next qt Next ws
请注意，此版本中不需要lovariables：