excel vba table query connection properties - vba

Question

I am trying to display the properties of all tables in a workbook. The code I am using is working but I am missing some information. As a matter of fact, some of the queries attached do not match the real query being used by the table
Below is the entire code used (the module wb parameter is a parameter from a user form list box)
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
Any ideas?
IG Data analyst
edit 1
drop box photo link (no account needed) there you can see the resulting screen. It shows in yellow the worksheet name and the corresponding table query. The stakeholder wants things to exactly match (the worksheet with the corresponding query).
enter image description here
The reason for the connection not matching the worksheet name that appears on the row is that the person who first worked on this workbook first changed many times over queries after creating query tables.