Sub ListWebQueryPivotTableLinks()
Dim wbA As Workbook, wsN As Worksheet, ws As Worksheet
Dim pt As PivotTable, qt As QueryTable, R As Long, i As Long
Dim vLnkSrc As Variant
Const PROGCREATE As String = "Dit externe " & _
"gegevensbereik is met behulp van " & _
"programmacode gemaakt en kan niet worden bewerkt"
On Error GoTo errHandler
Set wbA = ActiveWorkbook
Set wsN = Workbooks.Add(xlWorksheet).Worksheets(1)
wsN.Name = wbA.Name
wsN.Range("A1:E1").Value = Array("Name", "Location", _
"Type", "Connection", "CommandText")
wsN.Range("A1:E1").Font.Bold = True
R = 1
For Each ws In wbA.Worksheets
For Each pt In ws.PivotTables
R = R + 1
With pt.PivotCache
wsN.Cells(R, 1).Value = pt.Name
wsN.Cells(R, 2).Value = ws.Name & "!" & _
pt.TableRange2.Address(False, False)
Select Case .SourceType
Case xlConsolidation
R = R - 1
For i = 1 To UBound(.SourceData)
R = R + 1
wsN.Cells(R, 1).Value = pt.Name
wsN.Cells(R, 2).Value = ws.Name & "!" & _
pt.TableRange2.Address(False, False)
wsN.Cells(R, 3).Value = _
"Draaitabel - Samenvoegingsbereik"
wsN.Cells(R, 4).Value = "'" & _
.SourceData(i, 1)
wsN.Cells(R, 5).Value = "n.v.t."
Next
Case xlDatabase
wsN.Cells(R, 3).Value = "Draaitabel - Excel-lijst"
wsN.Cells(R, 4).Value = "'" & .SourceData
wsN.Cells(R, 5).Value = "n.v.t."
Case xlExternal
If .OLAP Then
wsN.Cells(R, 3).Value = "Draaitabel - OLAP"
wsN.Cells(R, 4).Value = "'" & .Connection
wsN.Cells(R, 5).Value = .CommandText
ElseIf .QueryType = xlADORecordset Then
wsN.Cells(R, 3).Value = _
"Draaitabel - ADO-recordset"
wsN.Cells(R, 4).Value = PROGCREATE
wsN.Cells(R, 5).Value = "'" & .Recordset.Source
Else
wsN.Cells(R, 3).Value = _
"Draaitabel - Externe gegevens"
wsN.Cells(R, 4).Value = "'" & .Connection
wsN.Cells(R, 5).Value = .CommandText
End If
Case xlScenario
wsN.Cells(R, 3).Value = "Draaitabel - Scenario"
wsN.Cells(R, 4).Value = "Gebaseerd op een scenario " & _
"in deze werkmap"
wsN.Cells(R, 5).Value = "n.v.t."
End Select
End With
Next
For Each qt In ws.QueryTables
R = R + 1
wsN.Cells(R, 1).Value = qt.Name
wsN.Cells(R, 2).Value = ws.Name & "!" & _
qt.ResultRange.Address(False, False)
Select Case qt.QueryType
Case xlTextImport
wsN.Cells(R, 3).Value = "Text importeren"
wsN.Cells(R, 4).Value = "'" & qt.Connection
wsN.Cells(R, 5).Value = "n.v.t."
Case xlOLEDBQuery
wsN.Cells(R, 3).Value = "Querytabel - OLEDB-query"
wsN.Cells(R, 4).Value = "'" & qt.Connection
wsN.Cells(R, 5).Value = "'" & qt.CommandText
Case xlWebQuery
wsN.Cells(R, 3).Value = "Webquerytabel"
wsN.Cells(R, 4).Value = "'" & qt.Connection
wsN.Cells(R, 5).Value = "n.v.t."
Case xlADORecordset
wsN.Cells(R, 3).Value = "Querytabel - ADO-recordset"
wsN.Cells(R, 4).Value = PROGCREATE
wsN.Cells(R, 5).Value = "'" & qt.Recordset.Source
Case xlDAORecordset
wsN.Cells(R, 3).Value = "Querytabel - DAO-recordset"
On Error Resume Next
wsN.Cells(R, 4).Value = "'" & qt.Recordset.Parent.Name
If Err.Number <> 0 Then
wsN.Cells(R, 4).Value = PROGCREATE
Err.Clear
End If
wsN.Cells(R, 5).Value = "'" & qt.Recordset.Name
If Err.Number <> 0 Then
wsN.Cells(R, 5).Value = PROGCREATE
Err.Clear
End If
On Error GoTo errHandler
Case xlODBCQuery
wsN.Cells(R, 3).Value = "Querytabel"
wsN.Cells(R, 4).Value = "'" & qt.Connection
wsN.Cells(R, 5).Value = qt.CommandText
End Select
Next
Next
vLnkSrc = wbA.LinkSources
If Not IsEmpty(vLnkSrc) Then
For i = 1 To UBound(vLnkSrc)
R = R + 1
wsN.Cells(R, 1).Value = "n.v.t."
wsN.Cells(R, 2).Value = "n.v.t."
wsN.Cells(R, 3).Value = "Koppelingsbron (Bewerken | Koppelingen)"
wsN.Cells(R, 4).Value = vLnkSrc(i)
Next
End If
wsN.Cells.WrapText = False
wsN.Columns.AutoFit
wsN.UsedRange.AutoFilter
Exit Sub
errHandler:
MsgBox "Er is een fout opgetreden." & vbCr & Err.Number & _
vbCr & Err.Description
Resume Next
End Sub
