AW: mehrere Zeilen aus mehreren Datein einfü
30.05.2020 01:02:05
fcs
Hallo Roman,
ich habe das Makro angepasst zur Suche der letzten Zeile in Spalte B und zum Kopieren der Zellen in den Nachbarspalten.
Ich hab es allerdings nicht getestet.
LG
Franz
Sub DatenImportieren()
Dim sVerzeichnis$, sDatei$
Dim wbZiel As Workbook, wbQuelle As Workbook
Dim wksZiel As Worksheet, wksQuelle As Worksheet
Dim ZeileZ&, FileCount&
Dim Zeile_L As Long, Zeile_1 As Long, Spalte As Long
Dim rngCopy As Range
Const Startzelle$ = "B17"
On Error GoTo Fehler
'Suchverzeichnis auswahlen
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Ordner mit zu durchsuchenden Dateien wählen"
.ButtonName = "Auswälen"
If .Show = -1 Then
sVerzeichnis = .SelectedItems(1)
sDatei = Dir(sVerzeichnis & Application.PathSeparator & "*.xl*")
If sDatei "" Then
'neue Datei mit einem Tabellenblatt für Ergebnisdaten erstellen
Set wbZiel = Workbooks.Add(Template:=xlWBATWorksheet)
'Zieltabellenblatt Objektvariable zuweisen
Set wksZiel = wbZiel.Worksheets(1)
ZeileZ = 1
With wksZiel
'Titelzeile ausfüllen
.Cells(ZeileZ, 1) = "Werte Spalte C"
.Cells(ZeileZ, 2) = "Werte Süalte D"
.Cells(ZeileZ, 3) = "Dateiname"
End With
ZeileZ = 2
Else
MsgBox "Keine Excel-Dateien im Verzeichnis"
GoTo Fehler
End If
Application.ScreenUpdating = False
Do Until sDatei = ""
FileCount = FileCount + 1
Application.StatusBar = "Datei, laufende Nr. " & FileCount & " wird bearbeitet."
'Quelldatei schreibgeschützt öffnen
Set wbQuelle = Workbooks.Open( _
Filename:=sVerzeichnis & Application.PathSeparator & sDatei, _
ReadOnly:=True)
'Tabelle1 Objektvariable zuweisen
Set wksQuelle = wbQuelle.Worksheets(1)
'Werte aus Blatt 1 kopieren
With wksQuelle
With .Range(Startzelle)
Zeile_1 = .Row
Spalte = .Column
End With
'letzte Zeile mit Inhalt in Spalte mit Startzelle
Zeile_L = .Cells(.Rows.Count, Spalte).End(xlUp).Row
Set rngCopy = .Range(.Cells(Zeile_1, Spalte + 1), _
.Cells(Zeile_L, Spalte + 2))
End With
With wksZiel
rngCopy.Copy .Cells(ZeileZ, 1)
'in Spalte C den Dateinamen eintragen
.Range(.Cells(ZeileZ, 3), .Cells(ZeileZ + Zeile_L - Zeile_1, 3)) = sDatei
End With
'nächste Einfügezeile
ZeileZ = ZeileZ + Zeile_L - Zeile_1 + 1
wbQuelle.Close savechanges:=False
Set rngCopy = Nothing
Set wksQuelle = Nothing
Set wbQuelle = Nothing
sDatei = Dir
Loop
Application.ScreenUpdating = True
MsgBox "Alle Dateien ausgelesen"
End If
End With
Err.Clear
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
Application.ScreenUpdating = True
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
If Not wbQuelle Is Nothing Then wbQuelle.Close savechanges:=False
End Select
End With
Set wbZiel = Nothing
Set wbQuelle = Nothing
Application.StatusBar = False
End Sub