AW: Bestimmten Blattnamen suchen in Ordner
28.01.2019 22:18:02
Sepp
Hallo Mablu,
der Code listet die Dateien die das entsprechende Tabellenblatt enthalten ab Zeile 2 in der aktiven Tabelle.
Modul Modul1
Option Explicit
Sub searchSheetInFiles()
Dim strFile As String, strPath As String
Dim lngRow As Long, varSheets As Variant, varRet As Variant
Const conSHEET_NAME As String = "Verbesserungen" 'gesuchter Tabellenname
strPath = "D:\Downloads\Forum" 'verzeichnis
lngRow = 2
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
strFile = Dir(strPath & "*.xls*", vbNormal)
With ActiveSheet 'oder Sheets("Tabellenname")
.Range("A2:A" & .Rows.Count).Clear
Do While strFile <> ""
varSheets = GetSheetNames(strPath & strFile)
If IsNumeric(Application.Match(conSHEET_NAME, varSheets, 0)) Then
.Hyperlinks.Add Anchor:=.Cells(lngRow, 1), Address:=strPath & strFile, TextToDisplay:=strFile
lngRow = lngRow + 1
End If
strFile = Dir
Loop
End With
End Sub
Private Function GetSheetNames(ByVal FileName As String) As Variant
'original by Bob Phillips, adapted by j.ehrensberger
Dim objADO As Object, objCAT As Object, objTAB As Object
Dim lngI As Long, intL As Integer, intP As Integer, intS As Integer
Dim strCon As String, strTab As String
Dim vntTmp() As Variant
If Mid(FileName, InStrRev(FileName, ".") + 1) = "xls" Then
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Extended Properties=Excel 8.0;" & _
"Data Source=" & FileName & ";"
ElseIf Mid(FileName, InStrRev(FileName, ".") + 1) Like "xls?" Then
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Extended Properties=""Excel 12.0;HDR=YES"";" _
& "Data Source=" & FileName & ";"
Else
Exit Function
End If
Set objADO = CreateObject("ADODB.Connection")
objADO.Open strCon
Set objCAT = CreateObject("ADOX.Catalog")
Set objCAT.ActiveConnection = objADO
For Each objTAB In objCAT.Tables
strTab = objTAB.Name
intL = Len(strTab)
intP = 0
intS = 1
'Worksheet name with embedded spaces enclosed by single quotes
If Left(strTab, 1) = "'" And Right(strTab, 1) = "'" Then
intP = 1
intS = 2
End If
'Worksheet names always end in the "$" character
If Mid$(strTab, intL - intP, 1) = "$" Then
Redim Preserve vntTmp(lngI)
vntTmp(lngI) = Mid$(strTab, intS, intL - (intS + intP))
lngI = lngI + 1
End If
Next objTAB
If lngI > 0 Then GetSheetNames = vntTmp
objADO.Close
Set objCAT = Nothing
Set objADO = Nothing
End Function
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0