AW: Excel Dateien zu einer zusammenfuehren
08.11.2021 16:17:05
Stefan
Hallo Werner,
super, jetzt läuft es, wie es soll. Ganz herzlichen Dank für deine Hilfe.
Für die Nachwelt hier der komplette funktionierende Code:
Sub a()
' Tabellenblatt "Adressen zusammengeführt" löschen, falls es existiert
Application.DisplayAlerts = False
Dim sh
For Each sh In Sheets
If sh.Name = "Adressen zusammengeführt" Then
Sheets("Adressen zusammengeführt").Delete
End If
Next
Application.DisplayAlerts = True
' neues Tabellenblatt anlegen und benennen
Sheets.Add after:=Sheets(Worksheets.Count)
ActiveSheet.Name = "Adressen zusammengeführt"
Const BLATT$ = "Adressen"
Dim WbZ As Workbook: Set WbZ = ThisWorkbook
Dim WsZ As Worksheet: Set WsZ = WbZ.Worksheets(2)
Dim WbQ As Workbook, SuchDialog As FileDialog
Dim WsQ As Worksheet
Dim Pfad$, DatenBereich As Range, Datei$, DateBereich As Range
Dim Von&, Bis&
' Bildschirmausgabe deaktivieren (will ich aber sehen :-))
' Application.ScreenUpdating = False
' Quellverzeichnis auswählen
Set SuchDialog = Application.FileDialog(msoFileDialogFolderPicker)
With SuchDialog
.Title = "Bitte Verzeichnis wählen"
.AllowMultiSelect = False
If .Show -1 Then
MsgBox "Vorgang abgebrochen", vbInformation
Exit Sub
Else: Pfad = .SelectedItems(1)
End If
End With
Datei = Dir(Pfad & "\" & "*.xls*", vbDirectory)
Do Until Datei = vbNullString
If Not Datei = WbZ.Name Then
Set WbQ = Workbooks.Open(Pfad & "\" & Datei)
With WbQ.Worksheets(BLATT)
' Spalten A bis U werden aus Quelle kopiert
Set DatenBereich = .Range("A1:U" & .UsedRange.Rows.Count)
DatenBereich.Copy
' kopierte Daten werden ans Ziel angefügt
With WsZ
If WorksheetFunction.CountA(.Rows(1)) = 0 Then
.Cells(1, "A").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Else
.Cells(.UsedRange.Rows.Count, "A").Offset(1).PasteSpecial xlPasteValuesAndNumberFormats
End If
End With
End With
Application.CutCopyMode = False: WbQ.Close False
End If
Datei = Dir
Loop
' Zeilen mit Feldnamen löschen
Dim i As Long
For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If Cells(i, 1) = "Magazine" Then Rows(i).Delete
Next i
MsgBox "Daten der Dateien aus " & Pfad & " wurden kopiert", vbInformation, "Vorgang beendet!"
Set WbZ = Nothing
Set WsZ = Nothing
Set WbQ = Nothing
Set WsQ = Nothing
Set DatenBereich = Nothing
End Sub
Und hier der Link zum Download:
https://www.herber.de/bbs/user/149007.xlsm
Viele Grüße Stefan