Erweiterung Import
16.07.2015 21:35:08
Bernd
folgendes Makro, das mir vorliegt (Danke Sepp!) importiert einen vorgegebenen Zellbereich eine vorgegebenen Tabellenblatts aus mehreren Exceldateien. Die zu importierenden Tabellenblätter und Zellbereiche sind identisch. Lässt sich das Makro insofern flexibilisieren, dass ich auch
mehrere Tabellenblätter mit unterschiedlichen Zellbereichen aus auszuwählenden Importdateien einlesen kann? Die Struktur der einzulesenden Importdateien ist einheitlich (Tabellenblätter identisch).
Es wäre schön, wen mir da jemand helfen kann. Vielleicht sogar Sepp, dem ich den tollen Erstcode zu verdanken habe.
Gruß,
Bernd
Option Explicit
Private Const cstrSheetName As String = "Test" 'Name des zu importierenden Tabellenblattes!
Private Const cstrRef As String = "A1:AM6000" 'Importbereich
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
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = -4135
.DisplayAlerts = False
End With
With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = "D:\Schriftverkehr\Herber" '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:AN" & .Rows.Count) = ""
lngNext = 2
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
strTable = cstrSheetName
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
.Cells(1, lngN) = "Aus Datei"
End If
.Cells(lngNext, 1).CopyFromRecordset objADO
.Cells(lngNext, lngN).Resize(objADO.RecordCount, 1) = vntFiles(lngI)
.Cells(lngNext, lngN).Hyperlinks.Add anchor:=.Cells(lngNext, lngN), Address:=vntFiles(lngI), SubAddress:=""
lngNext = lngNext + objADO.RecordCount
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
' requires the function FileExists()
Dim SQL As String
Dim Con As String
If Not FileExists(Path) Then Exit Function
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 FileExists(FileName As String) As Boolean
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
FileExists = objFSO.FileExists(FileName)
Set objFSO = Nothing
End Function