I've listed a set of macros below that I wrote quite some time ago. Running
the 'QueriesList' macro will list all the queries in the workbook and their
sources.
--
Hope this helps.
If it does, please click the Yes button.
Thanks in advance for your feedback.
Gary Brown
'S T A R T O F M A C R O s
'Public iDriveType As Integer
Public strNetwork As String
'/==============================================/
Sub QueriesList()
On Error Resume Next
'Purpose of this VBA program is to find and list all Queries
'in a Workbook
' For use with EXCEL 97 or higher
' written by Gary L. Brown
'
Dim iRow As Long, iColumn As Long, dblLastRow
Dim i As Integer
Dim x As Integer, iWorksheets As Integer
Dim objOutputArea As Object
Dim qryTable As QueryTable
Dim strQueryParameters As String
Dim strRngAddress As String
Dim strResultsTableName As String
Dim strOrigCalcStatus As String
Dim wksWorksheet As Worksheet
'/- - Initialize various Variables - -/
strResultsTableName = "Queries_Table"
strQueryParameters = ""
strRngAddress = ""
x = 0
'/- - - - - - - - - - - - - - - - - -/
'save calculation setting
Select Case Application.Calculation
Case xlCalculationAutomatic
strOrigCalcStatus = "Automatic"
Case xlCalculationManual
strOrigCalcStatus = "Manual"
Case xlCalculationSemiautomatic
strOrigCalcStatus = "SemiAutomatic"
Case Else
strOrigCalcStatus = "Automatic"
End Select
'set workbook to manual
Application.Calculation = xlManual
'check to see if there are any MS Queries in active workbook
For Each wksWorksheet In ActiveWorkbook.Worksheets
For Each qryTable In wksWorksheet.QueryTables
If wksWorksheet.QueryTables.Count > 0 Then
x = 1
Exit For
End If
Next qryTable
If x = 1 Then
Exit For
End If
Next wksWorksheet
If x = 1 Then 'proceed if there are active MS Queries in Wkbk
'Check for duplicate Worksheet name
i = ActiveWorkbook.Sheets.Count
For x = 1 To i
If Windows.Count = 0 Then Exit Sub
If UCase(Worksheets(x).name) = _
UCase(strResultsTableName) Then
Worksheets(x).Activate
If Err.Number = 9 Then
Exit For
End If
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
'Exit Sub
End If
Next
'Add new worksheet at end of workbook
' where results will be located
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
'Name the new worksheet and set up Titles
ActiveWorkbook.ActiveSheet.name = strResultsTableName
ActiveWorkbook.ActiveSheet.Range("A1").value = _
"Worksheet/Range"
ActiveWorkbook.ActiveSheet.Range("B1").value = "Query Name"
ActiveWorkbook.ActiveSheet.Range("C1").value = "Connection"
ActiveWorkbook.ActiveSheet.Range("D1").value = "Parameters"
ActiveWorkbook.ActiveSheet.Range("E1").value = "SQL"
'Count number of worksheets in workbook
iWorksheets = ActiveWorkbook.Sheets.Count
'Initialize row and column counts for putting info into
' strResultsTableName sheet
iRow = 1
iColumn = 0
Set objOutputArea = _
ActiveWorkbook.Sheets(strResultsTableName).Range("A1")
'evaluate all queries in the workbook
If Windows.Count = 0 Then
Exit Sub
End If
For Each wksWorksheet In ActiveWorkbook.Worksheets
For Each qryTable In wksWorksheet.QueryTables
With objOutputArea
'put information into strResultsTableName worksheet
strRngAddress = _
FindQueryRange(qryTable.name, wksWorksheet.name)
If Len(strRngAddress) > 0 Then
'Syntax is different for local vs. network drives
If strNetwork = "LOCAL" Then
.Hyperlinks.Add Anchor:=.Offset(iRow, iColumn), _
Address:="", _
SubAddress:=wksWorksheet.name & "!" & _
ChangeQueryNameToRangeName(qryTable.name), _
TextToDisplay:=Chr(39) & " " & _
Right(strRngAddress, Len(strRngAddress) - 1)
Else
.Hyperlinks.Add Anchor:=.Offset(iRow, iColumn), _
Address:="", SubAddress:=Chr(39) & _
wksWorksheet.name & Chr(39) & "!" & _
ChangeQueryNameToRangeName(qryTable.name), _
TextToDisplay:=Chr(39) & " " & _
Right(strRngAddress, Len(strRngAddress) - 1)
End If
End If
.Offset(iRow, iColumn + 1) = " " & qryTable.name
.Offset(iRow, iColumn + 2) = qryTable.Connection
strQueryParameters = "# of Parameters: " & _
qryTable.Parameters.Count
If qryTable.Parameters.Count > 0 Then
strQueryParameters = strQueryParameters & vbLf & _
" Parameters: "
For x = 1 To qryTable.Parameters.Count
strQueryParameters = _
strQueryParameters & vbLf & " - " & _
qryTable.Parameters(x).PromptString
Next x
End If
.Offset(iRow, iColumn + 3) = " " & strQueryParameters
.Offset(iRow, iColumn + 4) = qryTable.Sql
iRow = iRow + 1
End With
Next qryTable
Next wksWorksheet
'Release all variables from memory
Set objOutputArea = Nothing
'formatting output
Columns("A:E").Select
With Selection
.WrapText = False
End With
Columns("A:E").EntireColumn.AutoFit
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
.WrapText = True
End With
With Selection.Font
.Underline = xlUnderlineStyleSingleAccounting
End With
Range("A2").Select
ActiveWindow.FreezePanes = True
Columns("A:A").Select
If Selection.ColumnWidth > 50 Then
Selection.ColumnWidth = 50
End If
With Selection
.WrapText = True
End With
Columns("B:B").Select
If Selection.ColumnWidth > 50 Then
Selection.ColumnWidth = 50
End If
With Selection
.WrapText = True
End With
Columns("C:C").Select
If Selection.ColumnWidth > 50 Then
Selection.ColumnWidth = 50
End If
With Selection
.WrapText = True
.EntireColumn.AutoFit
End With
Columns("D
").Select
If Selection.ColumnWidth > 50 Then
Selection.ColumnWidth = 50
End If
With Selection
.WrapText = True
.EntireColumn.AutoFit
End With
Columns("E:E").Select
If Selection.ColumnWidth > 75 Then
Selection.ColumnWidth = 75
End If
With Selection
.WrapText = True
End With
Cells.Select
With Selection
.EntireRow.AutoFit
.VerticalAlignment = xlTop
End With
Range("A1").Select
'formatting printing
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
End With
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.5)
.BottomMargin = Application.InchesToPoints(0.5)
.HeaderMargin = Application.InchesToPoints(0.25)
.FooterMargin = Application.InchesToPoints(0.25)
.Orientation = xlLandscape
.Order = xlOverThenDown
.Zoom = 80
.LeftHeader = "&""Tms Rmn,Bold""&U&A"
.LeftFooter = "Printed: &D - &T"
.CenterFooter = "Page &P of &N"
.RightFooter = "&F-&A"
.PrintGridlines = True
.FitToPagesWide = 1
.FitToPagesTall = False
End With
ActiveWindow.Zoom = 75
Else
MsgBox "There are no MS Queries in this Workbook." & _
vbCr & vbCr & "Query Listing ended.", _
vbInformation + vbOKOnly, "No MS Queries found..."
End If
're-set to original calculation method
Select Case strOrigCalcStatus
Case "Automatic"
Application.Calculation = xlCalculationAutomatic
Case "Manual"
Application.Calculation = xlCalculationManual
Case "SemiAutomatic"
Application.Calculation = xlCalculationSemiautomatic
Case Else
Application.Calculation = xlCalculationAutomatic
End Select
Application.Dialogs(xlDialogWorkbookName).Show
End Sub
'/==============================================/
Private Function FindQueryRange(strQueryName As String, _
strWorksheetName As String) As String
Dim nRangeName As name
Dim strRangeAddress As String
Dim strRangeName As String
'initialize
FindQueryRange = ""
strNetwork = ""
strRangeAddress = ""
strRangeName = ""
'step 1 is to make the Query name correspond to the
' range name because query names can use all sorts
' of special characters while range names can only
' use a limited range of characters.
' The rest of the special characters are translated to an
' underscore "_".
'
strRangeName = ChangeQueryNameToRangeName(strQueryName)
'step 2 is to find the range name to get the range address
' - single quotation (')/Chr(39) syntax is used
' for network addresses
strRangeName = Chr(39) & strWorksheetName & Chr(39) & "!" & _
strRangeName
'check for network address - if local string will be empty
For Each nRangeName In ActiveWorkbook.Names
If nRangeName.name = strRangeName Then
strRangeAddress = nRangeName.RefersTo
Exit For
End If
Next nRangeName
'if the string came back empty
' then the address is from a local drive
If Len(strRangeAddress) = 0 Then
strRangeName = ChangeQueryNameToRangeName(strQueryName)
strRangeName = strWorksheetName & "!" & strRangeName
For Each nRangeName In ActiveWorkbook.Names
If nRangeName.name = strRangeName Then
strRangeAddress = nRangeName.RefersTo
Exit For
End If
Next nRangeName
strNetwork = "LOCAL"
End If
FindQueryRange = strRangeAddress
End Function
'/==============================================/
Private Function ChangeQueryNameToRangeName(strQueryName1)
Dim i As Integer, x As Integer
Dim strRngName As String
strRngName = ""
i = Len(strQueryName1)
For x = 1 To i
'check for: 0-9, A-Z, a-z, . , ? , _ , \
'Range names can ONLY include these characters.
' All others are changed to an underscore "_"
If Not ((Asc(Mid(strQueryName1, x, 1)) >= 48 And _
Asc(Mid(strQueryName1, x, 1)) <= 57) _
Or (Asc(Mid(strQueryName1, x, 1)) >= 65 And _
Asc(Mid(strQueryName1, x, 1)) <= 90) _
Or (Asc(Mid(strQueryName1, x, 1)) >= 97 And _
Asc(Mid(strQueryName1, x, 1)) <= 122) _
Or (Asc(Mid(strQueryName1, x, 1)) = 46) _
Or (Asc(Mid(strQueryName1, x, 1)) = 63) _
Or (Asc(Mid(strQueryName1, x, 1)) = 92) _
Or (Asc(Mid(strQueryName1, x, 1)) = 95)) Then
strRngName = strRngName & "_"
Else
strRngName = strRngName & Mid(strQueryName1, x, 1)
End If
Next x
ChangeQueryNameToRangeName = strRngName
End Function
'/==============================================/
'E N D O F M A C R O s
