AW: Geschlossene Excel-Dateien prüfen
14.08.2010 21:33:46
Josef
Hallo Timo,
probier mal folgenden Code.
Er schreibt die Dateien, in denen das gesuchte Tabellenblatt nicht vorhanden ist, ab Zeile 2 in Spalte A auf dem aktiven Tabellenblatt.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub CheckSheetInFiles()
Dim strPath As String, strFile As String, strSheetname As String
Dim vntSheets As Variant, vntRet As Variant
Dim lngRow As Long
strPath = "E:\Office\Excel" 'Pfad - anpassen!
strPath = IIf(Right(strPath, 1) <> "\", strPath & "\", "")
strSheetname = "Tabelle1" 'gesuchtes Tabellenblatt - anpassen!
lngRow = 2
strFile = Dir(strPath & "*.xls*")
With ActiveSheet
Do While strFile <> ""
vntSheets = GetSheetNames(strPath & strFile)
vntRet = Application.Match(strSheetname, vntSheets, 0)
If IsError(vntRet) Then
.Cells(lngRow, 1) = 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_Connection As Object, objADO_Catalog As Object, objADO_Tables As Object
Dim lngIndex As Long, intLength As Integer, intPos As Integer, intStart As Integer
Dim strConString As String, strTable As String
Dim vntTmp() As Variant
'If Dir(FileName, vbNormal) = "" Then Exit Function
On Error Resume Next
If Mid(FileName, InStrRev(FileName, ".") + 1) = "xls" Then
strConString = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Extended Properties=Excel 8.0;" & _
"Data Source=" & FileName & ";"
ElseIf Mid(FileName, InStrRev(FileName, ".") + 1) Like "xls?" Then
strConString = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Extended Properties=""Excel 12.0;HDR=YES"";" _
& "Data Source=" & FileName & ";"
Else
Exit Function
End If
Set objADO_Connection = CreateObject("ADODB.Connection")
objADO_Connection.Open strConString
Set objADO_Catalog = CreateObject("ADOX.Catalog")
Set objADO_Catalog.ActiveConnection = objADO_Connection
For Each objADO_Tables In objADO_Catalog.Tables
strTable = objADO_Tables.Name
intLength = Len(strTable)
intPos = 0
intStart = 1
'Worksheet name with embedded spaces enclosed by single quotes
If Left(strTable, 1) = "'" And Right(strTable, 1) = "'" Then
intPos = 1
intStart = 2
End If
'Worksheet names always end in the "$" character
If Mid$(strTable, intLength - intPos, 1) = "$" Then
Redim Preserve vntTmp(lngIndex)
vntTmp(lngIndex) = Mid$(strTable, intStart, intLength - (intStart + intPos))
lngIndex = lngIndex + 1
End If
Next objADO_Tables
If lngIndex > 0 Then GetSheetNames = vntTmp
objADO_Connection.Close
On Error GoTo 0
Set objADO_Catalog = Nothing
Set objADO_Connection = Nothing
End Function
Gruß Sepp