Option Explicit
Option Explicit
Public Sub ungetestet()
Dim neu As Workbook
Dim blatt As Worksheet
Dim merkevent As Boolean
Dim merkalarm As Boolean
Dim merkupdate As Boolean
Dim fs As FileSearch
Dim gefunden
With Application
merkevent = .EnableEvents
merkalarm = .DisplayAlerts
merkupdate = .ScreenUpdating
End With
Set neu = Workbooks.Add
Set fs = Application.FileSearch
With fs
.NewSearch
.Filename = "*.xls"
.LookIn = "C:\Test"
.Execute
merkevent = False
merkalarm = False
merkupdate = False
For Each gefunden In .FoundFiles
Workbooks.Open (gefunden)
For Each blatt In gefunden
blatt.Copy after:=neu.Sheets(neu.Sheets.Count)
gefunden.Close False
Next blatt
Next gefunden
End With
With Application
.EnableEvents = merkevent
.DisplayAlerts = merkalarm
.ScreenUpdating = merkupdate
End With
End Sub
Option Explicit
Sub basMappe_kons()
Dim strArr, strWbk As String, _
strPath As String
Dim wbkQu As Workbook, wbkZi As Workbook, wks As Worksheet
Dim lngZ As Long
Dim objFD As FileDialog
Set objFD = Application.FileDialog(msoFileDialogFilePicker)
With objFD
.AllowMultiSelect = True
If .Show = -1 Then
ReDim strArr(0 To .SelectedItems.Count - 1)
For lngZ = 1 To .SelectedItems.Count
strArr(lngZ - 1) = .SelectedItems(lngZ)
Next
End If
End With
Set objFD = Nothing
Set objFD = Application.FileDialog(msoFileDialogFolderPicker)
With objFD
.AllowMultiSelect = False
If .Show - 1 Then
For lngZ = 1 To .SelectedItems.Count
strPath = .SelectedItems(lngZ)
If Right(strPath, 1) <> "\" Then _
strPath = strPath & "\"
Next
End If
End With
Set objFD = Nothing
strWbk = Application.InputBox("Bitte geben Sie einen Dateinamen ein !", "Dateinamen eingeben ?")
If strWbk = "" Then Exit Sub
If Right(strWbk, 4) <> ".xls" Then _
strWbk = strWbk & ".xls"
Set wbkZi = Application.Workbooks.Add
For lngZ = 0 To UBound(strArr)
Set wbkQu = GetObject(strArr(lngZ))
For Each wks In wbkQu.Worksheets
wks.Copy after:=wbkZi.Sheets(Worksheets.Count)
Next
Set wbkQu = Nothing
Next
wbkZi.SaveAs strPath & strWbk
Set wbkZi = Nothing
End Sub
Option Explicit
Public Sub getestet()
Dim neu As Workbook
Dim blatt As Worksheet
Dim merkevent As Boolean
Dim merkalarm As Boolean
Dim merkupdate As Boolean
Dim fs As FileSearch
Dim gefunden
With Application
merkevent = .EnableEvents
merkalarm = .DisplayAlerts
merkupdate = .ScreenUpdating
End With
Set neu = Workbooks.Add
Set fs = Application.FileSearch
With fs
.NewSearch
.Filename = "*.xls"
.LookIn = "C:\Test"
.Execute
merkevent = False
merkalarm = False
merkupdate = False
For Each gefunden In .FoundFiles
Workbooks.Open (gefunden)
For Each blatt In Workbooks(Dir(gefunden)).Sheets
blatt.Copy after:=neu.Sheets(neu.Sheets.Count)
Next blatt
Workbooks(Dir(gefunden)).Close False
Next gefunden
End With
With Application
.EnableEvents = merkevent
.DisplayAlerts = merkalarm
.ScreenUpdating = merkupdate
End With
End Sub