Option Explicit
Sub Allesamt()
Dim oTargetSheet As Excel.Worksheet
Dim oSourceBook As Excel.Workbook
Dim sPfad As String
Dim sDatei As String
Dim Flag As Boolean
Dim TargetRange As Range
Dim strNeuCSV As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
sPfad = ThisWorkbook.Path & "\MeinTest\"
sDatei = Dir(sPfad & "*.xlsx*")
Do While sDatei <> ""
If Not Flag Then
Set oSourceBook = Workbooks.Open(sPfad & sDatei)
oSourceBook.Sheets(1).Copy
Set oTargetSheet = ActiveWorkbook.Sheets(1)
With oTargetSheet
.Rows(1).Insert
.Cells(1).Value = oSourceBook.Name
With .UsedRange
Set TargetRange = .Rows(.Rows.Count).Cells(1).Offset(2)
End With
End With
oSourceBook.Close False
Flag = True
Else
Set oSourceBook = Workbooks.Open(sPfad & sDatei)
oSourceBook.Sheets(1).UsedRange.Copy TargetRange
TargetRange.Offset(-1).Value = oSourceBook.Name
oSourceBook.Close False
With oTargetSheet.UsedRange
Set TargetRange = .Rows(.Rows.Count).Cells(1).Offset(2)
End With
End If
sDatei = Dir
Loop
strNeuCSV = InputBox("CSV-Dateiname ", "Speichern unter", "Test")
If Len(strNeuCSV) Then
strNeuCSV = Replace(strNeuCSV, ".", "")
strNeuCSV = Replace(LCase(strNeuCSV), "csv", "")
With oTargetSheet.Parent
.SaveAs Filename:=sPfad & strNeuCSV & ".csv", _
FileFormat:=xlCSV, CreateBackup:=False, Local:=True
.Close True
End With
Else
Call MsgBox("aktive Datei " & oTargetSheet.Parent.Name, vbExclamation)
End If
End Sub