AW: Datei in einer Datei
29.08.2022 14:17:13
UweD
Hallo
hier noch eine VBA Lösung von mir
Option Explicit
Sub alle_Dateien_Verzeichnis() '
On Error GoTo Fehler
Dim Pfad As String, Ext As String, Datei As String, Datum As String
Dim WB As Workbook, TBx As Worksheet, Anz As Integer, NeuNam As String
Dim LR1 As Long, LR2 As Long, RNG As Range, Sp As Integer, Z1 As Integer
Dim Leer As Range
'****Anpassen
Ext = "*.xlsx"
Sp = 1 ' Spalte A
Z1 = 2 'Daten an Zeile 2
Pfad = "L:\Markt\Bestände\" '**** mit \
Application.ScreenUpdating = False 'Flackern ausschalten
Datum = InputBox("Verzeichnis", "Eingabe", Format(Date, "DD.MM.YYYY"))
If Not IsDate(Datum) Then
MsgBox ("Fehler Eingabe")
Exit Sub
Else
'prüfen, ob Verz. existiert
If Dir(Pfad & Datum, vbDirectory) = "" Then
MsgBox ("Verzeichnis :" & Datum & " existiert nicht")
Exit Sub
Else
Pfad = Pfad & Datum & "\"
End If
End If
Datei = Dir(Pfad & Ext)
Do While Len(Datei) > 0
Workbooks.Open Filename:=Pfad & Datei
Set TBx = ActiveWorkbook.Sheets(1)
If Anz = 0 Then
'nur bei erster Datei, Blatt kopieren
TBx.Copy
Set WB = ActiveWorkbook
NeuNam = "Gesamt " & Datum & ".xlsx"
Else
'alle Weiteren, die Zeilen anhängen
With WB.Sheets(1)
LR1 = .Cells(.Rows.Count, Sp).End(xlUp).Row + 1 'erste freie Zeile der Spalte
LR2 = TBx.Cells(TBx.Rows.Count, Sp).End(xlUp).Row
TBx.Rows(2).Resize(LR2 - Z1 + 1).Copy .Rows(LR1)
End With
End If
Anz = Anz + 1
Workbooks(Datei).Close False 'ohne speichern
Datei = Dir() ' nächste Datei
Loop
If Anz > 0 Then
'Leerzeilen löschen
With ActiveSheet.Range("$A2:$A" & LR1 + LR2 - Z1)
If WorksheetFunction.CountBlank(.Cells) > 0 Then
'Es sind Leerzellen in A vorhanden
Set Leer = .SpecialCells(xlCellTypeBlanks)
Leer.EntireRow.Delete xlUp
End If
End With
WB.SaveAs (Pfad & NeuNam)
WB.Close
End If
MsgBox Anz & ": Dateien wurden verarbeitet"
Err.Clear
Fehler:
If Err.Number 0 Then MsgBox "Fehler: " & _
Err.Number & vbLf & Err.Description: Err.Clear
End Sub
LG UweD