' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub collectData()
Dim strPath As String, strFile As String, strRef As String, strTab As String
Dim vntRef As Variant
Dim lngI As Long, lngNext As Long
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlManual
.DisplayAlerts = False
End With
vntRef = Array("B4", "B10", "B14", "C14", "D14", "B15", "C15", "D15", "B16", "C16", "D16", "B17", _
"C17", "D17", "B18", "C18", "D18")
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "E:\Forum" 'Startverzeichnis
.Title = "Datenimport Ordnerauswahl"
.ButtonName = "Import Starten"
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strPath = .SelectedItems(1)
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
End If
End With
With ThisWorkbook.Sheets("Tabelle1")
lngNext = Application.Max(4, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
If Len(strPath) Then
strFile = Dir(strPath & "*.xls*", vbNormal)
Do While strFile <> ""
If strFile <> ThisWorkbook.Name Then
strTab = GetSheetNames(strPath & strFile)(0)
DoEvents
Application.StatusBar = "Imort aus Datei: " & strFile & " Bitte warten..."
DoEvents
strRef = "='" & strPath & "[" & strFile & "]" & strTab & "'!"
For lngI = 1 To UBound(vntRef) + 1
.Cells(lngNext, lngI).Formula = strRef & vntRef(lngI - 1)
Next
lngNext = lngNext + 1
strFile = Dir
End If
Loop
End If
.Calculate
.Range(.Cells(4, 1), .Cells(lngNext, UBound(vntRef) + 1)) = .Range(.Cells(4, 1), .Cells(lngNext, _
UBound(vntRef) + 1)).Value
End With
ErrExit:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'collectData'" & vbLf & String(60, "_") & vbLf & vbLf & _
IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & "Fehlernummer:" & vbTab & _
.Number & vbLf & vbLf & "Beschreibung:" & vbTab & .Description & vbLf, vbExclamation + _
vbMsgBoxSetForeground, "VBA - Fehler in Prozedur - collectData"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlAutomatic
.DisplayAlerts = True
.StatusBar = False
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