Exceldateien durchsuchen, die Abfragen auf SQL Server stellen

  • Excel

Es gibt 2 Antworten in diesem Thema. Der letzte Beitrag () ist von Bot-Like.

    Exceldateien durchsuchen, die Abfragen auf SQL Server stellen

    Hallo an Alle,

    ich brauche mal einen Excel-perten der mir weiterhilft. Wir haben die Aufgabe bekommen, dass wir das Ganze Firmennetzwerk auf Exceldateien durchsuchen sollen, die Abfragen zu unserem SQL Server stellen.
    Das habe ich auch soweit hinbekommen. Nur scheitere ich jetzt leider an einem Detail. Ich kannte bisher nur die Möglichkeit, dass man eine Abfrage in Excel erstellt, die dan in Tabellenform erstellt wird.
    Diese wird auch problemlos von unten stehendem Code gefunden.
    Kollegen (die nicht mehr bei uns arbeiten) haben aber auch Excel-Tools erstellt, bei den die Abfragen direkt in eine Pivot Tabelle münden.
    Augenscheinlich sind das die Problemkinder die von meinem code nicht erfasst werden.

    Habt Ihr schonmal von sowas gehört?


    Visual Basic-Quellcode

    1. Function QuerysAuslesen(ByVal Excel_Datei_Pfad)
    3. On Error GoTo Fehlerbehandlung
    5. Set AktionSHELL = CreateObject("WScript.Shell")
    6. DesktopPfad = AktionSHELL.SpecialFolders("Desktop")
    7. Textdatei_pfad = DesktopPfad & "\Excel_documents_with_querys.txt"
    10. Application.Workbooks.Open Excel_Datei_Pfad, False, True
    12. Dim qrt As QueryTable, objListObject As ListObject, iIndex As Integer
    13. Dim wsh As Worksheet
    14. Dim bAddList As Boolean
    15. Dim qrt_Anzahl As Integer
    16. qrt_Anzahl = 0
    18. QUERY_STRING = ""
    20. For Each wsh In ActiveWorkbook.Worksheets
    22. For Each qrt In wsh.QueryTables
    23. qrt_Anzahl = qrt_Anzahl + 1
    25. Reiter = wsh.Name
    26. Verbindungs_zeichen_folge = qrt.Connection
    27. Abfrage = qrt.Sql
    28. Abfrage = Replace(Abfrage, vbCrLf, " ")
    29. Abfrage = Replace(Abfrage, vbCr, " ")
    30. Abfrage = Replace(Abfrage, vbLf, " ")
    31. Abfrage = Replace(Abfrage, vbTab, " ")
    33. Pfad_zerlegen ActiveWorkbook.FullName, Verzeichnis, Dateiname, Dateiendung
    35. Date_LastAccessed = Dateieigenschaften_auslesen_vba(ActiveWorkbook.FullName, "Date_LastAccessed")
    37. QUERY_STRING = vbTab & Dateiname & "." & Dateiendung & vbTab & Verzeichnis & vbTab & vbTab & Abfrage & vbTab & vbTab & Date_LastAccessed & vbTab & Verbindungs_zeichen_folge & vbTab & Reiter
    38. Text_Datei_Schreiben QUERY_STRING, Textdatei_pfad
    40. Next
    42. iIndex = 0
    45. For Each objListObject In wsh.ListObjects
    46. iIndex = iIndex + 1
    47. With objListObject
    48. If .SourceType = xlSrcQuery Then
    49. Set qrt = .QueryTable
    50. qrt_Anzahl = qrt_Anzahl + 1
    52. Reiter = wsh.Name
    53. Verbindungs_zeichen_folge = qrt.Connection
    54. Abfrage = qrt.Sql
    55. Abfrage = Replace(Abfrage, vbCrLf, " ")
    56. Abfrage = Replace(Abfrage, vbCr, " ")
    57. Abfrage = Replace(Abfrage, vbLf, " ")
    58. Abfrage = Replace(Abfrage, vbTab, " ")
    60. Pfad_zerlegen ActiveWorkbook.FullName, Verzeichnis, Dateiname, Dateiendung
    62. Date_LastAccessed = Dateieigenschaften_auslesen_vba(ActiveWorkbook.FullName, "Date_LastAccessed")
    64. QUERY_STRING = vbTab & Dateiname & "." & Dateiendung & vbTab & Verzeichnis & vbTab & vbTab & Abfrage & vbTab & vbTab & Date_LastAccessed & vbTab & Verbindungs_zeichen_folge & vbTab & Reiter
    65. Text_Datei_Schreiben QUERY_STRING, Textdatei_pfad
    67. End If
    69. End With
    71. Next
    75. Next
    77. ActiveWorkbook.Close False
    80. Fehlerbehandlung:
    81. If Err.Number = 1004 Then
    82. Exit Function
    83. Resume
    84. End If
    88. End Function

    Bilder

    • SqlPivot_WIRD_NICHT_ERFASST.jpg

      130,32 kB, 1.366×623, 128 mal angesehen

    • SqlTbl_WIRD_ERFASST.jpg

      126,22 kB, 1.360×608, 123 mal angesehen

    Dieser Beitrag wurde bereits 2 mal editiert, zuletzt von „Bot-Like“ ()

    Hi,

    die Vermutung mit dem Pivot hat sich nicht bewahrheitet.
    Ich habe noch eine Andere Möglichkeit gefunden die Verbindungen auszulesen. Da war dann alles mit dabei was ich brauchte.
    Vorher hatte es OLEDBConnections glaube ich nicht mit erfasst.

    Jedenfalls findet Ihr unten nochmal das komplette Macro, falls das noch jemand verwerten kann.
    Spoiler anzeigen

    Visual Basic-Quellcode

    1. Sub Main()
    2. Titel = "Excel Dateien mit Query suchen"
    6. Main_Verzeichnis = InputBox("Bitte geben Sie ein UNC Verzeichnis an, dass Sie durchsuchen wollen", Titel, "C:\Users\???\Desktop\Neuer Ordner")
    8. If Main_Verzeichnis <> "" Then
    11. AlleDateien Main_Verzeichnis
    14. End If
    16. MsgBox "Das Ergebnis liegt auf Ihrem Desktop, als Textdatei.", vbInformation, Titel
    18. End Sub
    20. Function AlleDateien(ByVal Pfad As String)
    22. Dim ScriptObject As Object
    23. Set ScriptObject = CreateObject("Scripting.FileSystemObject")
    24. Dim StartOrdner As Object
    25. Set StartOrdner = ScriptObject.GetFolder(Pfad)
    26. Dateien StartOrdner.Files
    27. Ordner StartOrdner
    28. End Function
    30. Private Sub Dateien(Ordner As Object)
    31. Dim Datei As Object
    32. For Each Datei In Ordner
    33. File_Name = Datei.Name
    34. File_Path = Datei.Path
    35. If (InStr(UCase(File_Name), ".XLSX") <> 0 Or InStr(UCase(File_Name), ".XLSM") <> 0) And Left(File_Name, 2) <> "~$" Then
    37. Set AktionSHELL = CreateObject("WScript.Shell")
    38. DesktopPfad = AktionSHELL.SpecialFolders("Desktop")
    39. INI_FILE = DesktopPfad & "\Search_for_Excel_documents_with_querys_PROBLEMFILES.txt"
    41. Dateigröße = Dateieigenschaften_auslesen_vba(File_Path, "Size")
    42. Auslassen = INI_auslesen_angepasst(INI_FILE, File_Path)
    45. If Dateigröße > 5000 And Auslassen = False Then
    46. QuerysAuslesen (File_Path)
    47. End If
    49. End If
    50. Next
    52. End Sub
    54. Function Ordner(objOrdner As Object)
    56. Dim Unterordner As Object
    57. For Each Unterordner In objOrdner.SubFolders
    58. Dateien Unterordner.Files
    59. Ordner Unterordner
    60. Next
    62. End Function
    64. Function QuerysAuslesen(ByVal Excel_Datei_Pfad)
    66. Dim pt As PivotTable
    68. On Error GoTo Fehlerbehandlung
    70. Set AktionSHELL = CreateObject("WScript.Shell")
    71. DesktopPfad = AktionSHELL.SpecialFolders("Desktop")
    72. Textdatei_pfad = DesktopPfad & "\Excel_documents_with_querys.txt"
    75. Application.Workbooks.Open Excel_Datei_Pfad, False, True
    77. Dim qrt As QueryTable, objListObject As ListObject, iIndex As Integer
    78. Dim wsh As Worksheet
    79. Dim bAddList As Boolean
    80. Dim qrt_Anzahl As Integer
    81. qrt_Anzahl = 0
    83. QUERY_STRING = ""
    84. Text_schreiben_erlaubt = False
    86. Verbindungs_Anzahl = ActiveWorkbook.Connections.Count
    88. For i = 1 To Verbindungs_Anzahl
    90. Verbindungsname = ActiveWorkbook.Connections.Item(i).Name
    92. Vebindungstyp = ActiveWorkbook.Connections.Item(i).Type
    94. If Vebindungstyp = 1 Then
    96. Abfrage = ActiveWorkbook.Connections.Item(i).OLEDBConnection.CommandText
    97. Verbindungs_zeichen_folge = ActiveWorkbook.Connections.Item(i).OLEDBConnection.Connection
    98. Text_schreiben_erlaubt = True
    100. ElseIf Vebindungstyp = 2 Then
    102. Abfrage = ActiveWorkbook.Connections.Item(i).ODBCConnection.CommandText
    103. Verbindungs_zeichen_folge = ActiveWorkbook.Connections.Item(i).ODBCConnection.Connection
    104. Text_schreiben_erlaubt = True
    106. Else
    107. Text_schreiben_erlaubt = False
    108. End If
    111. If Text_schreiben_erlaubt = True Then
    113. Abfrage = Replace(Abfrage, vbCrLf, " ")
    114. Abfrage = Replace(Abfrage, vbCr, " ")
    115. Abfrage = Replace(Abfrage, vbLf, " ")
    116. Abfrage = Replace(Abfrage, vbTab, " ")
    118. Pfad_zerlegen ActiveWorkbook.FullName, Verzeichnis, Dateiname, Dateiendung
    120. Date_LastAccessed = Dateieigenschaften_auslesen_vba(ActiveWorkbook.FullName, "Date_LastAccessed")
    122. If Len(Abfrage) > 32700 Then
    124. QUERY_STRING = vbTab & Dateiname & "." & Dateiendung & vbTab & Verzeichnis & vbTab & vbTab
    125. QUERY_STRING = QUERY_STRING & Left(Abfrage, 32700) & vbTab & vbTab & Date_LastAccessed & vbTab & Verbindungs_zeichen_folge & vbTab
    126. QUERY_STRING = QUERY_STRING & "ATTENTION the SQL code was too long for an Excel cell and is continued in the last column" & vbTab & Mid(Abfrage, 32701, Len(Abfrage) - 32700)
    128. Else
    130. QUERY_STRING = vbTab & Dateiname & "." & Dateiendung & vbTab & Verzeichnis & vbTab & vbTab
    131. QUERY_STRING = QUERY_STRING & Abfrage & vbTab & vbTab & Date_LastAccessed & vbTab & Verbindungs_zeichen_folge
    133. End If
    135. Text_Datei_Schreiben QUERY_STRING, Textdatei_pfad
    137. End If
    139. Next
    142. ActiveWorkbook.Close False
    145. Fehlerbehandlung:
    146. If Err.Number = 1004 Then
    147. Exit Function
    148. Resume
    149. End If
    153. End Function
    155. Function Pfad_zerlegen(ByVal Pfad, ByRef Verzeichnis, ByRef Dateiname, ByRef Dateiendung)
    157. Pfad_array = Split(Pfad, "\")
    158. Dateiname_mit_Erweiterung = Pfad_array(UBound(Pfad_array))
    159. Verzeichnis = Replace(Pfad, "\" & Dateiname_mit_Erweiterung, "")
    160. Dateiname_array = Split(Dateiname_mit_Erweiterung, ".")
    161. Dateiendung = Dateiname_array(UBound(Dateiname_array))
    162. Dateiname = Dateiname_array(0)
    164. End Function
    166. Function Text_Datei_Schreiben(ByVal InputString, ByVal Zielpfad)
    168. Set AktionFSO = CreateObject("Scripting.FileSystemObject")
    170. If AktionFSO.FileExists(Zielpfad) = False Then
    171. AktionFSO.CreateTextFile (Zielpfad)
    172. End If
    174. Set Datei = AktionFSO.OpenTextFile(Zielpfad, 8)
    175. Datei.Writeline InputString
    176. Datei.Close
    178. End Function
    180. Function Dateieigenschaften_auslesen_vba(ByVal Dateipfad, ByVal gesuchter_Wert)
    182. Set fs = CreateObject("Scripting.FileSystemObject")
    183. Set f = fs.GetFile(Dateipfad)
    184. Date_LastModified = f.DateLastModified
    185. Date_Created = f.DateCreated
    186. Date_LastAccessed = f.DateLastAccessed
    187. Size = f.Size
    188. Typ = f.Type
    190. If gesuchter_Wert = "Date_LastModified" Then
    191. Dateieigenschaften_auslesen_vba = Date_LastModified
    192. ElseIf gesuchter_Wert = "Date_Created" Then
    193. Dateieigenschaften_auslesen_vba = Date_Created
    194. ElseIf gesuchter_Wert = "Date_LastAccessed" Then
    195. Dateieigenschaften_auslesen_vba = Date_LastAccessed
    196. ElseIf gesuchter_Wert = "Size" Then
    197. Dateieigenschaften_auslesen_vba = Size
    198. ElseIf gesuchter_Wert = "Typ" Then
    199. Dateieigenschaften_auslesen_vba = Typ
    200. Else
    201. Dateieigenschaften_auslesen_vba = ""
    202. End If
    204. End Function
    206. Function INI_auslesen_angepasst(ByVal INI_FILE, ByVal Inputwert)
    208. Set AktionFSO = CreateObject("Scripting.FileSystemObject")
    209. Set AktionSHELL = CreateObject("WScript.Shell")
    210. DesktopPfad = AktionSHELL.SpecialFolders("Desktop")
    212. Ergebnis = False
    214. If AktionFSO.FileExists(INI_FILE) = False Then
    215. INI_auslesen_angepasst = Ergebnis
    216. Exit Function
    217. End If
    219. Set INI_Datei = AktionFSO.OpenTextFile(INI_FILE, 1)
    221. While Not INI_Datei.AtEndOfStream
    222. INI_Textzeile = INI_Datei.Readline
    224. If Inputwert = INI_Textzeile Then
    225. Ergebnis = True
    226. End If
    228. Wend
    229. INI_Datei.Close
    231. INI_auslesen_angepasst = Ergebnis
    233. End Function



    aufgrund des Codeumfangs Spoiler hinzugefügt ~VaporiZed

    Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „VaporiZed“ ()

Facebook
Telefonspende