Geschlossene Dateien - ADO - Tabellenblatt!

Frage: Der Tabellenblattname kann nicht genau festgelegt werden. Es können zwei verschiedene Namen sein. Dies geht aber nicht, wenn quasi geschlossene Dateien per Formel ausgelesen werden. Hier wird per ADO geprüft, welches Tabellenblatt in der Datei ist.

Geschlossene Dateien - ADO - Tabellenblatt...[ZIP, 140 KB]

Option Explicit
Const strSheetZ As String = "Tabelle1" ' Die Tabelle in dieser Datei
Const strCellQ1 As String = "L8" ' Die Zelle wird ausgelesen
Const strCellQ2 As String = "L6" ' Die Zelle wird ausgelesen
Public Sub Files_Read()
Dim stCalc As Integer
Dim strDir As String
Dim objFSO As Object
Dim objDir As Object
On Error GoTo Fin
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
stCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
' Wenn der Inhalt vorher gelöscht werden soll
' ThisWorkbook.Worksheets(strSheetZ).Columns("A:C").ClearContents
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Datei im gleichen Ordner wie Auswertungsdateien
strDir = ThisWorkbook.Path
Set objDir = objFSO.GetFolder(strDir)
'dirInfo objDir, "*.xls*", True ' Mit Unterordner
dirInfo objDir, "*.xls*"
Fin:
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = stCalc
.DisplayAlerts = True
End With
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
Set objDir = Nothing
Set objFSO = Nothing
End Sub
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
Optional ByVal blnTMP As Boolean = False)
Dim objWorkbook As Workbook
Dim strFormula As String
Dim lngLastRow As Long
Dim strSheet As String
Dim varTMP As Variant
For Each varTMP In objCurrentDir.Files
If varTMP.Name Like strName And varTMP.Name <> _
ThisWorkbook.Name Then
If Left(varTMP.Name, 1) <> "~" Then
strSheet = ADOSheet(varTMP.Path)
With ThisWorkbook.Worksheets(strSheetZ)
lngLastRow = IIf(Len(.Cells(.Rows.Count, 2)), _
.Rows.Count, .Cells(.Rows.Count, 2).End(xlUp).Row) + 1
With .Cells(lngLastRow, 2)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & _
strSheet & "'!" & strCellQ1
.Value = .Value
.Offset(0, -1).Value = varTMP.Name
End With
With .Cells(lngLastRow, 3)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, _
"\") + 1) & "]" & _
strSheet & "'!" & strCellQ2
.Value = .Value
End With
End With
End If
End If
Next varTMP
If blnTMP = True Then
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName, blnTMP
Next varTMP
End If
Set objWorkbook = Nothing
End Sub
Private Function ADOSheet(ByVal strFileName As String) As String
Dim strSheetQ1 As String
Dim strSheetQ As String
Dim objConn As Object
Dim objCat As Object
Dim objTab As Object
On Error GoTo Fin
strSheetQ1 = "Project_Data"
strSheetQ = "Projektdaten"
Set objConn = CreateObject("ADODB.Connection")
With objConn
.CursorLocation = 3 ' = adUseClient
If Val(Application.Version) >= 12 Then
.Provider = "Microsoft.ACE.OLEDB.12.0;" & _
"Extended Properties=""Excel 12.0;HDR=YES"";" & _
"Data Source=" & strFileName & ";"
Else
.Provider = "Microsoft.Jet.OLEDB.4.0;" & _
"Extended Properties=Excel 8.0;" & _
"Data Source=" & strFileName & ";"
End If
.Open
End With
Set objCat = CreateObject("ADOX.Catalog")
Set objCat.ActiveConnection = objConn
For Each objTab In objCat.Tables
If objTab.Name Like "Project_*" Then
ADOSheet = strSheetQ1: Exit Function
ElseIf objTab.Name Like "Projektda*" Then
ADOSheet = strSheetQ: Exit Function
End If
Next objTab
Fin:
Set objCat = Nothing
If Not objConn Is Nothing Then
If objConn.State = 1 Then objConn.Close
End If
Set objConn = Nothing
End Function

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...