Option Explicit
Sub Zusammenführen()
Dim arrFiles() As Variant, x As Long
Dim flag As Boolean, rflag As Long
Dim rngToC As Range
On Error GoTo FilesFail
If Application.WorksheetFunction.CountA(Cells) = 0 Then flag = True
Application.ScreenUpdating = False
Application.DisplayAlerts = False
arrFiles = AskForFiles
For x = LBound(arrFiles) To UBound(arrFiles)
Workbooks.Open Filename:=arrFiles(x), ReadOnly:=True
If Application.WorksheetFunction.CountA(Cells) = 0 Then
Workbooks(2).Close
Else
Set rngToC = ActiveSheet.UsedRange
If flag = True Then
rngToC.Copy
Else
rflag = rngToC.Rows.Count
If rflag > 5 Then _
Set rngToC = rngToC.Offset(5, 0).Resize(rngToC.Rows.Count - 5, rngToC.Columns.Count)
rngToC.Copy
End If
Workbooks(2).Close
If flag = True Then
ActiveSheet.Paste Cells(1)
flag = False
Else
If rflag > 5 Then _
ActiveSheet.Paste Cells(Rows.Count, 1).End(xlUp).Offset(1)
End If
Application.CutCopyMode = False
End If
Next x
FilesFail:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Select Case Err.Number
Case 0
Case 9
MsgBox "keine Auswahl", vbOKOnly Or vbCritical, "Abbruch"
End
Case Else
MsgBox "Fehler im Dateiaufbau", vbOKOnly Or vbCritical, "Abbruch"
End
End Select
End Sub
Private Function AskForFiles() As Variant
Dim oFilePicker As Office.FileDialog
Dim varItem As Variant
Dim arrSelected() As Variant, x As Long
On Error GoTo NoFile
Set oFilePicker = Application.FileDialog(MsoFileDialogType.msoFileDialogFilePicker)
With oFilePicker
.AllowMultiSelect = True
.ButtonName = "Übernehmen"
.Filters.Clear
.Filters.Add "Excel", "*.xls; *.xlsx; *.xlsm"
.InitialView = msoFileDialogViewList
.Title = "Auswahldialog"
If .Show = -1 Then
ReDim arrSelected(1 To .SelectedItems.Count)
For Each varItem In .SelectedItems
x = x + 1: arrSelected(x) = varItem
Next varItem
End If
End With
NoFile:
On Error GoTo 0
Select Case Err.Number
Case 0
AskForFiles = arrSelected
Case Else
MsgBox "Fehler in der Dateiauswahl", vbOKOnly Or vbCritical, "Abbruch"
End
End Select
End Function