Question

我正在尝试显示工作簿中所有表的属性。我正在使用的代码正在运行，但我遗漏了一些信息。事实上，附加的一些查询与表

使用的实际查询不匹配

以下是使用的整个代码（模块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 Data分析师

编辑1

丢弃框照片链接（无需帐户），您可以在那里看到生成的屏幕。它以黄色显示工作表名称和相应的表查询。利益相关者希望事物完全匹配（工作表与相应的查询）。

enter image description here

连接与行上显示的工作表名称不匹配的原因是，在创建查询表后，首次使用此工作簿的人首次对查询进行了多次更改。

excel vba表查询连接属性

0 个答案: