Hallo Bernd,
in ein allgemeines Modul der Zusammenfassungs-Datei.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub import()
Dim objADO As Object
Dim vntItem As Variant
Dim vntFiles() As String, strTable As String, strFile As String, strPath As String
Dim lngI As Long, lngN As Long, lngNext As Long, lngCalc As Long
Const cstrRef As String = "A1:AM6000" 'Importbereich
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = -4135
.DisplayAlerts = False
End With
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = "E:\Forum" 'Startverzeichnis
.Title = "Dateien zum Import auswählen"
.ButtonName = "Import Starten"
.InitialView = msoFileDialogViewList
.AllowMultiSelect = True
.Filters.Clear
.Filters.Add "Excel Dateien", "*.xls; *.xlsx; *.xlsm", 1
.Filters.Add "Alle Dateien", "*.*", 2
.FilterIndex = 1
If .Show = -1 Then
Redim vntFiles(.SelectedItems.Count - 1)
For Each vntItem In .SelectedItems
vntFiles(lngI) = vntItem
lngI = lngI + 1
Next
End If
End With
If lngI > 0 Then
With ThisWorkbook.Sheets("Tabelle1") 'Name der Tabelle in dieser Datei - anpassen!
.Range("A1:AM" & .Rows.Count) = ""
For lngI = 0 To UBound(vntFiles)
DoEvents
strPath = Mid(vntFiles(lngI), 1, InStrRev(vntFiles(lngI), "\") - 1)
strFile = Mid(vntFiles(lngI), InStrRev(vntFiles(lngI), "\") + 1)
Application.StatusBar = "Import aus '" & strPath & "' - Datei: '" & strFile & _
"' - ( " & lngI + 1 & " von " & UBound(vntFiles) + 1 & " )"
DoEvents
lngNext = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
strTable = GetSheetNames(vntFiles(lngI))(0)
Set objADO = ExcelTable(vntFiles(lngI), strTable, cstrRef)
If lngI = 0 Then
For lngN = 1 To objADO.Fields.Count
.Cells(1, lngN) = objADO.Fields.Item(lngN - 1).Name
Next
End If
.Cells(lngNext, 1).CopyFromRecordset objADO
.Cells(lngNext, 40).Resize(objADO.RecordCount, 1) = vntFiles(lngI)
objADO.Close
Next
.Columns.AutoFit
End With
MsgBox "Import aus " & IIf(UBound(vntFiles) = 0, "einer Datei", UBound(vntFiles) + 1 & " Dateien") & _
" erfolgreich abgeschloßen!", vbInformation
End If
ErrExit:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'import'" & 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 - import"
.Clear
End If
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
.StatusBar = False
End With
On Error GoTo 0
Set objADO = Nothing
End Sub
Private Function ExcelTable(ByRef Path As String, ByRef Table As String, ByRef SourceRange As String, Optional WhereString As String = "") As Object
Dim SQL As String
Dim Con As String
SQL = "select * from [" & Table & "$" & SourceRange & "] " & WhereString
If Mid(Path, InStrRev(Path, ".") + 1) = "xls" Then
Con = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Extended Properties=Excel 8.0;" _
& "Data Source=" & Path & ";"
ElseIf Mid(Path, InStrRev(Path, ".") + 1) Like "xls?" Then
Con = "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "Extended Properties=""Excel 12.0;HDR=YES"";" _
& "Data Source=" & Path & ";"
Else
Exit Function
End If
Set ExcelTable = CreateObject("ADODB.Recordset")
ExcelTable.Open SQL, Con, 3, 1
End Function
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 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
Set objADO_Catalog = Nothing
Set objADO_Connection = Nothing
End Function
Gruß Sepp