alle Query Tables auslesen und auflisten
manhartm
Bis anhin hatten wir Excel 2002. Neu ist es Excel 2010 und nun geht dieser Code nicht mehr. Das heist es werden keine Querys gefunden.
Was muss geändert werden? Schaffs einfach nicht.. Sch.. 2010 das verstehe ich noch nicht
Danke und Gruss
Gruss
Martin
Die vier Makros machen folgendes
'Auslesen von allen Querys in ein Tabellenblatt
Sub QuerysAuslesen()
Dim qrt As ListObject
Dim wsh As Worksheet
Dim bAddList As Boolean
Dim qrt_Anzahl As Integer
qrt_Anzahl = 0
bAddList = True
For Each wsh In ActiveWorkbook.Worksheets
If wsh.Name = "QuerryTables" Then
bAddList = False
Exit For
End If
Next
If bAddList Then
ActiveWorkbook.Sheets.Add Before:=ActiveWorkbook.Worksheets(1)
ActiveSheet.Name = "QuerryTables"
End If
Sheets("QuerryTables").Cells(1, 1).Value = "BlattName"
Sheets("QuerryTables").Cells(1, 2).Value = "QueryName"
Sheets("QuerryTables").Cells(1, 3).Value = "ConnectionString"
Sheets("QuerryTables").Cells(1, 4).Value = "SQLString"
For Each wsh In ActiveWorkbook.Worksheets
For Each qrt In wsh.QueryTables
qrt_Anzahl = qrt_Anzahl + 1
Sheets("QuerryTables").Cells(1 + qrt_Anzahl, 1) = wsh.Name
Sheets("QuerryTables").Cells(1 + qrt_Anzahl, 2) = qrt.Name
Sheets("QuerryTables").Cells(1 + qrt_Anzahl, 3) = qrt.Connection
Sheets("QuerryTables").Cells(1 + qrt_Anzahl, 4) = qrt.Sql
Next
Next
If qrt_Anzahl = 0 Then
MsgBox "Keine Queries in dieser Arbeitsmappe", vbExclamation
Else
MsgBox "Total " & qrt_Anzahl & " Queries in der Arbeitsmappe.", vbInformation
End If
End Sub
'Einlesen aller Querys in die jeweilige Tabelle
Sub QueriesEinlesen()
Dim qrt As QueryTable
Dim wsh As Worksheet
Dim Tab_vorhanden As Boolean
Dim qrt_Anzahl As Integer
Tab_vorhanden = False
For Each wsh In ActiveWorkbook.Worksheets
If wsh.Name = "QuerryTables" Then
Tab_vorhanden = True
Exit For
End If
Next
If Not (Tab_vorhanden) Then
MsgBox "QuerryTables existiert nicht !" & vbCrLf & _
"Keine Queries angepasst", vbCritical
Exit Sub
End If
For Each wsh In ActiveWorkbook.Worksheets
For Each qrt In wsh.QueryTables
qrt_Anzahl = 1
Do While Sheets("QuerryTables").Cells(1 + qrt_Anzahl, 1).Value ""
If wsh.Name = Sheets("QuerryTables").Cells(1 + qrt_Anzahl, 1).Value And _
qrt.Name = Sheets("QuerryTables").Cells(1 + qrt_Anzahl, 2) Then
qrt.Connection = Sheets("QuerryTables").Cells(1 + qrt_Anzahl, 3).Value
qrt.Sql = Sheets("QuerryTables").Cells(1 + qrt_Anzahl, 4).Value
MsgBox "Blatt:" & wsh.Name & vbCrLf & _
"Query:" & qrt.Name & " angepasst!", vbInformation
End If
qrt_Anzahl = qrt_Anzahl + 1
Loop
Next
Next
End Sub
Sub PivotSourceDataAuslesen()
Dim pvt As PivotTable
Dim wsh As Worksheet
Dim Tab_vorhanden As Boolean
Dim SourceArray As Variant
Dim ixArray As Integer
Dim pvt_Anzahl As Integer
pvt_Anzahl = 0
Tab_vorhanden = True
For Each wsh In ActiveWorkbook.Worksheets
If wsh.Name = "PivotSource" Then
Tab_vorhanden = False
Exit For
End If
Next
If Tab_vorhanden Then
ActiveWorkbook.Sheets.Add Before:=ActiveWorkbook.Worksheets(1)
ActiveSheet.Name = "PivotSource"
End If
Sheets("PivotSource").Cells(1, 1).Value = "Tabelle"
Sheets("PivotSource").Cells(1, 2).Value = "Pivot"
Sheets("PivotSource").Cells(1, 3).Value = "ArrayElements"
Sheets("PivotSource").Cells(1, 4).Value = "SourceData"
For Each wsh In ActiveWorkbook.Worksheets
For Each pvt In wsh.PivotTables
pvt_Anzahl = pvt_Anzahl + 1
Sheets("PivotSource").Cells(1 + pvt_Anzahl, 1) = wsh.Name
Sheets("PivotSource").Cells(1 + pvt_Anzahl, 2) = pvt.Name
SourceArray = pvt.SourceData
Sheets("PivotSource").Cells(1 + pvt_Anzahl, 3) = UBound(pvt.SourceData)
For ixArray = 1 To UBound(pvt.SourceData)
Sheets("PivotSource").Cells(1 + pvt_Anzahl, 3 + ixArray) = SourceArray(ixArray)
Next ixArray
Next
Next
If pvt_Anzahl = 0 Then
MsgBox "Keine Pivottabellen in dieser Arbeitsmappe", vbExclamation
Else
MsgBox "Total " & pvt_Anzahl & " Pivottabellen in der Arbeitsmappe.", vbInformation
End If
End Sub
Sub PivotSourceDataEinlesen()
Dim pvt As PivotTable
Dim wsh As Worksheet
Dim SourceArray As Variant
Dim ixArray As Integer
Dim Tab_vorhanden As Boolean
Dim pvt_Anzahl As Integer
Tab_vorhanden = False
For Each wsh In ActiveWorkbook.Worksheets
If wsh.Name = "PivotSource" Then
Tab_vorhanden = True
Exit For
End If
Next
If Not (Tab_vorhanden) Then
MsgBox "Keine PivotSourcedata vorhanden!" & vbCrLf & _
"Update nicht erfolgt!", vbCritical
Exit Sub
End If
For Each wsh In ActiveWorkbook.Worksheets
For Each pvt In wsh.PivotTables
pvt_Anzahl = 1
Do While Sheets("PivotSource").Cells(1 + pvt_Anzahl, 1).Value ""
If wsh.Name = Sheets("PivotSource").Cells(1 + pvt_Anzahl, 1).Value And _
pvt.Name = Sheets("PivotSource").Cells(1 + pvt_Anzahl, 2) Then
ReDim SourceArray(1 To Sheets("PivotSource").Cells(1 + pvt_Anzahl, 3).Value) _
For ixArray = 1 To Sheets("PivotSource").Cells(1 + pvt_Anzahl, 3).Value
SourceArray(ixArray) = Sheets("PivotSource").Cells(1 + pvt_Anzahl, 3 + _
ixArray).Value
Next ixArray
pvt.SourceData = SourceArray
MsgBox "Blatt:" & wsh.Name & vbCrLf & _
"Pivot:" & pvt.Name & " angepasst!", vbInformation
End If
pvt_Anzahl = pvt_Anzahl + 1
Loop
Next
Next
End Sub