AW: Blätter aus einzelnen Dateien übertragen
25.09.2020 14:39:03
fcs
Hallo Paul,
hier das Makro nochmals erweitert,
- Titelzeile wird nur kopiert, wenn noch keine Daten im Zielblatt vorhanden
- leere Zeilen bzw. Zeilen, die nur Leerzeichen enthalten werden gelöscht.
LG
Franz
Sub Protokolle_zusammenstellen()
Dim varOrdner
Dim xFilesToOpen As Variant
Dim rngCopy As Range
Dim spa As Long, Spa_L As Long, Zei_L As Long, zei_Z
Dim xWb As Workbook, xSh As Worksheet
Dim xTempWb As Workbook, xTempSh As Worksheet
Dim StatusCalc As Long
Dim bolStatus As Boolean, Zeile_1 As Long
On Error GoTo ErrHandler
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Ordner mit den Protokolldateien auswählen"
If .Show = -1 Then
varOrdner = .SelectedItems(1)
Else
Exit Sub
End If
End With
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
End With
'Ziel-Datei setzen
Set xWb = ActiveWorkbook
'Ziel-Tabellenblatt setzen
Set xSh = xWb.Worksheets("Protokolle") 'Name ggf anpassen
With xSh
zei_Z = .UsedRange.Row + .UsedRange.Rows.Count - 1
If Not IsEmpty(.Cells(zei_Z, 1)) Then
zei_Z = zei_Z + 1
bolStatus = False
Else
bolStatus = True 'Titelzeile mit kopieren
End If
Zeile_1 = zei_Z
End With
'Dateien im Ordner suchen
xFilesToOpen = Dir(varOrdner & "\*.xlsm")
Do Until xFilesToOpen = ""
'Datei schreibgeschützt öffnen
Set xTempWb = Application.Workbooks.Open(varOrdner & "\" & xFilesToOpen, ReadOnly:=True)
Set xTempSh = xTempWb.Sheets(7) 'Nummer des Registers ggf. anpassen
xTempSh.Visible = xlSheetVisible
With xTempSh.UsedRange
Zei_L = .Row + .Rows.Count - 1
Spa_L = .Column + .Columns.Count - 1
End With
With xTempSh
If bolStatus = True Then
'Titelzeile mit kopieren
Set rngCopy = .Range(.Cells(1, 1), .Cells(Zei_L, Spa_L))
bolStatus = False
Else
'Titelzeile nicht mit kopieren
Set rngCopy = .Range(.Cells(2, 1), .Cells(Zei_L, Spa_L))
End If
End With
rngCopy.Copy
xSh.Cells(zei_Z, 1).PasteSpecial Paste:=xlPasteFormats
xSh.Cells(zei_Z, 1).PasteSpecial Paste:=xlPasteValues
zei_Z = zei_Z + rngCopy.Rows.Count
Application.CutCopyMode = False
xTempWb.Close savechanges:=False
Set xTempWb = Nothing
xFilesToOpen = Dir
Loop
'leere Zeilen erfassen und löschen
With xSh
Set rngCopy = Nothing
Zei_L = zei_Z - 1
For zei_Z = Zei_L To Zeile_1 Step -1
bolStatus = False
For spa = 1 To Spa_L
If Trim(.Cells(zei_Z, spa).Text) "" Then
bolStatus = True
Exit For
End If
Next
If bolStatus = False Then
If rngCopy Is Nothing Then
Set rngCopy = .Rows(zei_Z)
Else
Set rngCopy = Application.Union(rngCopy, .Rows(zei_Z))
End If
End If
Next
If Not rngCopy Is Nothing Then
rngCopy.Delete
End If
End With
ExitHandler:
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
.EnableEvents = True
End With
Exit Sub
ErrHandler:
MsgBox "Fehler-Nr.: " & Err.Number & vbLf & Err.Description, , "Error!"
If Not xTempWb Is Nothing Then
xTempWb.Close savechanges:=False
End If
Resume ExitHandler
End Sub