Home » Infrastructure » Windows » Free to use, Helpful VBA Code to extract ODBC Connect Details form Excel Query an Excel Pivot Query
( ) 1 Vote
 Free to use, Helpful VBA Code to extract ODBC Connect Details form Excel Query an Excel Pivot Query [message #214427] |
Tue, 16 January 2007 07:30 |
rustico64
Messages: 3
Registered: January 2007
Location: Switzerland
|
Junior Member |
|
|
Hi all in there
here a VBA code to extract connection string and sql statements of excel files after a switch into a new DB or set new Login and or password. Microsoft Query does not allow to change the SQL or Connection String.
Free to use, it creates a new Table to extract the details. After the extract, you can change the details and import back to the Excel sheet.
This codes help me out of many sleepless nights! 
Regards
Martin
'1. for standard Query to extract
Sub QuerysAuslesen()
Dim qrt As QueryTable
Dim wsh As Worksheet
Dim bAddList As Boolean
Dim iQueryCnt As Integer
iQueryCnt = 0
bAddList = True
For Each wsh In ActiveWorkbook.Worksheets
If wsh.Name = "QueryList" Then
bAddList = False
Exit For
End If
Next
If bAddList Then
ActiveWorkbook.Sheets.Add Before:=ActiveWorkbook.Worksheets(1)
ActiveSheet.Name = "QueryList"
End If
Sheets("QueryList").Cells(1, 1).Value = "BlattName"
Sheets("QueryList").Cells(1, 2).Value = "QueryName"
Sheets("QueryList").Cells(1, 3).Value = "ConnectionString"
Sheets("QueryList").Cells(1, 4).Value = "SQLString"
For Each wsh In ActiveWorkbook.Worksheets
For Each qrt In wsh.QueryTables
iQueryCnt = iQueryCnt + 1
Sheets("QueryList").Cells(1 + iQueryCnt, 1) = wsh.Name
Sheets("QueryList").Cells(1 + iQueryCnt, 2) = qrt.Name
Sheets("QueryList").Cells(1 + iQueryCnt, 3) = qrt.Connection
Sheets("QueryList").Cells(1 + iQueryCnt, 4) = qrt.Sql
Next
Next
If iQueryCnt = 0 Then
MsgBox "Keine Queries in dieser Arbeitsmappe", vbExclamation
Else
MsgBox "Total " & iQueryCnt & " Queries in der Arbeitsmappe.", vbInformation
End If
End Sub
'2. for standard Query to import
Sub QueriesEinlesen()
Dim qrt As QueryTable
Dim wsh As Worksheet
Dim bExistList As Boolean
Dim iQueryCnt As Integer
bExistList = False
For Each wsh In ActiveWorkbook.Worksheets
If wsh.Name = "QueryList" Then
bExistList = True
Exit For
End If
Next
If Not (bExistList) Then
MsgBox "QueryList existiert nicht !" & vbCrLf & _
"Keine Queries angepasst", vbCritical
Exit Sub
End If
For Each wsh In ActiveWorkbook.Worksheets
For Each qrt In wsh.QueryTables
iQueryCnt = 1
Do While Sheets("QueryList").Cells(1 + iQueryCnt, 1).Value <> ""
If wsh.Name = Sheets("QueryList").Cells(1 + iQueryCnt, 1).Value And _
qrt.Name = Sheets("QueryList").Cells(1 + iQueryCnt, 2) Then
qrt.Connection = Sheets("QueryList").Cells(1 + iQueryCnt, 3).Value
qrt.Sql = Sheets("QueryList").Cells(1 + iQueryCnt, 4).Value
MsgBox "Blatt:" & wsh.Name & vbCrLf & _
"Query:" & qrt.Name & " angepasst!", vbInformation
End If
iQueryCnt = iQueryCnt + 1
Loop
Next
Next
End Sub
'3. for Pivot querys extract
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
'4. for Pivot querys extract
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
[Updated on: Tue, 16 January 2007 07:32] Report message to a moderator |
|
|
|
Goto Forum:
Current Time: Sun Nov 24 20:22:00 CST 2024
|
] 
Blog
Search
Help
Members
Register
Login
Home
