excel vba表查询连接属性

我正在尝试显示工作簿中所有表的属性。 我正在使用的代码正在工作，但我缺less一些信息。 事实上，附加的一些查询与表中使用的实际查询不匹配

以下是使用的全部代码（模块wb参数是来自用户表单列表框的参数）

Public Sub WbkConnProperties(wb As Workbook) Dim WS As Worksheet Dim objWBConnect As WorkbookConnection Dim vWs() As String Dim lOffset As Long Dim lastr As Long, lastc As Long Dim wsnm As String Dim i As Long Dim iex As Byte 'On Error Resume Next 'make sure we have at least one visible sheet Application.DisplayAlerts = False With ThisWorkbook 'For Each ws In .Worksheets ' If Not ws.Name = .Worksheets(1).Name Then ' ws.Delete ' End If 'Next ws ReDim vWs(ThisWorkbook.Worksheets.Count) i = 0 For Each WS In .Worksheets vWs(i) = WS.Name i = i + 1 Next WS wsnm = Left(wb.Name, 20) & Right(wb.Name, 5) iex = 0 For i = LBound(vWs, 1) To UBound(vWs, 1) If vWs(i) = wsnm & "_" & iex Or vWs(i) = wsnm Then iex = iex + 1 End If Next i If iex > 0 Then .Worksheets.Add After:=Worksheets(Worksheets.Count) .Worksheets(.Worksheets.Count).Name = wsnm & "_" & iex Set WS = .Worksheets(wsnm & "_" & iex) Else .Worksheets.Add After:=Worksheets(Worksheets.Count) .Worksheets(.Worksheets.Count).Name = wsnm Set WS = .Worksheets(wsnm) End If End With 'thisw Application.DisplayAlerts = True 'ActiveWindow.FreezePanes = False With WS.Range("A1:G1") .Value = Array("Worksheet name", "Connection Name", _ "Data file source", "Sql Query text", "Data file path", _ "Connection String", "Connection Type") End With '________________________________________________________________________ '___ '___ col.1 - 0 - Nom de la feuille où se trouve le résultat de la requête '___ col.2 - 1 - Nom de la connection relative à la feuille col.1 '___ col.3 - 2 - Nom du classeur des données sources (si applicable) '___ col.4 - 3 - Requête sql '___ col.5 - 4 - Chemin du classeur des données sources '___ col.6 - 5 - Propriétés de la connection '___ col.7 - 6 - Type de la connection (pour info. ce code peut '___ s'appliquer pour les TCD) '________________________________________________________________________ 'ws.Cells.EntireColumn.AutoFit With WS With .Range("A1") lOffset = 0 For Each objWBConnect In wb.Connections lOffset = lOffset + 1 .Offset(lOffset, 0).Value = "nom_feuille" .Offset(lOffset, 1).Value = objWBConnect.Name .Offset(lOffset, 2).Value = "classeur_donnees_src" .Offset(lOffset, 6).Value = objWBConnect.Type If objWBConnect.Type = xlConnectionTypeODBC Then .Offset(lOffset, 3).Value = objWBConnect.ODBCConnection.CommandText .Offset(lOffset, 5).Value = objWBConnect.ODBCConnection.Connection .Offset(lOffset, 2).Value = FWorkbookName(.Offset(lOffset, 5).Value) .Offset(lOffset, 4).Value = FWorkbookPath(.Offset(lOffset, 5).Value) .Offset(lOffset, 0).Value = GetRange(wb, .Offset(lOffset, 1).Value) ElseIf objWBConnect.Type = xlConnectionTypeOLEDB Then .Offset(lOffset, 5).Value = objWBConnect.OLEDBConnection.Connection Else .Offset(lOffset, 5).Value = "Not Applicable" End If Next objWBConnect End With lastr = .Cells(.Rows.Count, 1).End(xlUp).Row lastc = .Cells(1, Columns.Count).End(xlToLeft).Column With .Cells .HorizontalAlignment = xlGeneral .VerticalAlignment = xlCenter End With .Columns("A:A").EntireColumn.AutoFit .Columns("B:B").ColumnWidth = 40 .Columns("C:C").ColumnWidth = 40 With .Columns("D:D") .ColumnWidth = 75 .Replace What:="`", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False End With .Columns("E:E").ColumnWidth = 50 .Columns("E:E").WrapText = True .Columns("F:F").ColumnWidth = 80 .Columns("F:F").WrapText = True With .Columns("G:G") .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .EntireColumn.AutoFit End With With .Range(.Cells(1, 1), .Cells(1, lastc)) .VerticalAlignment = xlCenter .HorizontalAlignment = xlCenter .RowHeight = 25 .Font.Bold = True End With With .Range(.Cells(2, 1), .Cells(lastr, lastc)) .VerticalAlignment = xlCenter .WrapText = True End With With .Columns("G:G") .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With End With 'ws End Sub Function FWorkbookName(mStr As String) Dim fstr As Variant, fstrB As Variant Dim FWstr As String 'Debug.Print mStr fstr = Split(mStr, ";") fstrB = Split(fstr(2), "\") FWstr = fstrB(UBound(fstrB, 1)) FWorkbookName = FWstr End Function Function FWorkbookPath(mStr As String) Dim fstr As Variant, fstrB As Variant Dim FWstr As String 'Debug.Print mStr fstr = Split(mStr, ";") FWstr = Right(fstr(3), Len(fstr(3)) - 11) FWorkbookPath = FWstr End Function Public Function GetRange(wbk As Workbook, ByVal sListName As String) As String Dim oListObject As ListObject 'Dim wbk As Workbook Dim WS As Worksheet 'Set wb = ThisWorkbook sListName = Replace(sListName, " ", "_") sListName = "Tableau_" & sListName For Each WS In wbk.Sheets For Each oListObject In WS.ListObjects If oListObject.Name = sListName Then GetRange = WS.Name & vbCrLf & "[" & Replace(oListObject.Range.Address, "$", "") & "]" Exit Function End If Next oListObject Next WS Dim conn As WorkbookConnection 'For Each conn In wbk.Connections ' Debug.Print conn.Name 'Next conn End Function 

有任何想法吗？

IG数据分析师

编辑1

下拉框照片链接（不需要帐户），你可以看到最终的屏幕。 它以黄色显示工作表名称和相应的表格查询。 利益相关者想要的东西完全匹配（工作表与相应的查询）。

在这里input图像说明

连接与行中出现的工作表名称不匹配的原因在于，在创build查询表之后，首先处理此工作簿的人首先在查询上进行了多次更改。