AW: Tabellenblatt im Ordner suchen?
25.01.2020 15:02:27
Nepumuk
Hallo Fred,
teste mal:
Option Explicit
Private Const FOLDER_PATH As String = "G:\Eigene Dateien\" 'Anpassen
Private Const SHEET_NAME As String = "Auswahl1"
Public Sub Beispiel()
Dim astrFolders() As String, strFileName As String
Dim ialngFolders As Long
Dim objWorkbook As Workbook
astrFolders = GetFolders(FOLDER_PATH)
For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
strFileName = Dir$(astrFolders(ialngFolders) & "*.xls*")
Do Until strFileName = vbNullString
If SearchSheet(astrFolders(ialngFolders) & strFileName) Then
Set objWorkbook = Workbooks.Open(Filename:=astrFolders(ialngFolders) & strFileName)
Stop ' mach was mit dem Workbook
Call objWorkbook.Close(SaveChanges:=False)
End If
strFileName = Dir$
Loop
Next
End Sub
Private Function GetFolders(ByVal pvstrPath As String) As String()
Dim astrFolders() As String
Dim strFolder As String, strPath As String
Dim ialngIndex1 As Long, ialngIndex2 As Long
Redim Preserve astrFolders(ialngIndex1)
astrFolders(ialngIndex1) = pvstrPath
ialngIndex1 = 1
ialngIndex2 = 1
strPath = pvstrPath
Do
strFolder = Dir$(PathName:=strPath & "*", Attributes:=vbDirectory)
Do Until strFolder = vbNullString
If strFolder <> "." And strFolder <> ".." Then
If GetAttr(PathName:=strPath & strFolder) And vbDirectory Then
Redim Preserve astrFolders(0 To ialngIndex1)
astrFolders(ialngIndex1) = strPath & strFolder & "\"
ialngIndex1 = ialngIndex1 + 1
End If
End If
strFolder = Dir$
Loop
If ialngIndex1 = ialngIndex2 Then Exit Do
strPath = astrFolders(ialngIndex2)
ialngIndex2 = ialngIndex2 + 1
Loop
GetFolders = astrFolders
End Function
Private Function SearchSheet(ByVal pvstrPath As String) As Boolean
Dim objConnection As Object, objCatalog As Object
Dim strConnection As String
Dim objTables As Object
Dim avntTemp As Variant
avntTemp = Split(pvstrPath, ".")
Select Case LCase$(avntTemp(UBound(avntTemp)))
Case "xlsm"
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & pvstrPath & ";" & _
"Extended Properties=""Excel 12.0 Macro;HDR=No;IMEX=0"""
Case "xlsx"
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & pvstrPath & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=No;IMEX=0"""
Case "xlsb"
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & pvstrPath & ";" & _
"Extended Properties=""Excel 12.0;HDR=No;IMEX=0"""
Case "xls"
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & pvstrPath & ";" & _
"Extended Properties=""Excel 8.0;HDR=No;IMEX=0"""
Case Else
Call MsgBox("Unbekannter Dateityp", vbCritical, "Fehler")
Exit Function
End Select
Set objConnection = CreateObject("ADODB.Connection")
Call objConnection.Open(strConnection)
Set objCatalog = CreateObject("ADOX.Catalog")
Set objCatalog.ActiveConnection = objConnection
For Each objTables In objCatalog.Tables
With objTables
If Left$(.Name, Len(.Name) - 1) = SHEET_NAME Then
SearchSheet = True
Exit For
End If
End With
Next
objConnection.Close
Set objTables = Nothing
Set objCatalog = Nothing
Set objConnection = Nothing
End Function
Gruß
Nepumuk