Sub KopieBlattInAlle()
Dim strFN As String
Application.EnableEvents = False
strFN = Dir(ThisWorkbook.Path & "\*.xlsx")
Do While strFN ""
If strFN ThisWorkbook.Name Then ' nicht in eigene Mappe
Workbooks.Open ThisWorkbook.Path & "\" & strFN
If SheetEx("Bewertung") Then
MsgBox "In Mappe" & strFN & _
"gibt es bereits ein Blatt 'Bewertung'"
' .Close False ' evtl. Schließen ohne Speichern
Else
With ActiveWorkbook ' Kopieren
ThisWorkbook.Sheets("Bewertung").Copy _
after:=.Sheets(.Sheets.Count)
.Close True ' Speichern und Schließen
End With
End If
End If
strFN = Dir()
Loop
Application.EnableEvents = True
End Sub
Function SheetEx(strNam As String) As Boolean
On Error Resume Next
SheetEx = ActiveWorkbook.Sheets(strNam).Index > 0
End Function
Sub KopieBlattInAlle()
Dim strFN As String
Application.EnableEvents = False
strFN = Dir(ThisWorkbook.Path & "\*.xls")
Do While strFN ""
If strFN ThisWorkbook.Name Then ' nicht in eigene Mappe
Workbooks.Open ThisWorkbook.Path & "\" & strFN
With ActiveWorkbook
If SheetEx("Bewertung") Then
MsgBox "In Mappe" & strFN & _
"gibt es bereits ein Blatt 'Bewertung'"
.Close False ' evtl. Schließen ohne Speichern
Else
ThisWorkbook.Sheets("Bewertung").Copy _
after:=.Sheets(.Sheets.Count) ' Kopieren
.Close True ' Speichern und Schließen
End If
End With
End If
strFN = Dir()
Loop
Application.EnableEvents = True
End Sub
Option Explicit
Dim arrErr(), lngErr As Long
Sub KopieBlattInAlle()
Dim aStrFN() As String, zz As Long, strFN As String
Dim myCalC As XlCalculation, blnDisp As Boolean
lngErr = 0 ' Dateiliste erzeugen
ReDim arrErr(1 To 5, 1 To 100)
ReDim aStrFN(1 To 100)
strFN = Dir(ThisWorkbook.Path & "\*.xls")
Do While strFN ""
zz = zz + 1
If zz > UBound(aStrFN) Then _
ReDim Preserve aStrFN(1 To 2 * UBound(aStrFN))
aStrFN(zz) = strFN
strFN = Dir()
Loop
If zz = 0 Then Exit Sub
ReDim Preserve aStrFN(1 To zz)
With Application
.EnableEvents = False
myCalC = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
blnDisp = .DisplayStatusBar
.DisplayStatusBar = True
End With
For zz = 1 To UBound(aStrFN)
Application.StatusBar = zz & " von " & UBound(aStrFN)
If aStrFN(zz) ThisWorkbook.Name Then ' nicht eigene Mappe
On Error Resume Next
Workbooks.Open ThisWorkbook.Path & "\" & aStrFN(zz), _
0, False, , , , True
If Err.Number = 0 Then
On Error GoTo 0
With ActiveWorkbook
If SheetEx("Bewertung") Then
ErrListe "Hinw", "Blatt ex.", _
aStrFN(zz), 0, "Blatt 'Bewertung'"
.Close False ' Schließen ohne Speichern
Else
On Error Resume Next
ThisWorkbook.Sheets("Bewertung").Copy _
after:=.Sheets(.Sheets.Count) ' Kopieren
If Err.Number 0 Then _
ErrListe "Fehler", "Copy", _
aStrFN(zz), Err.Number, Err.Description
On Error Resume Next
.Save ' Speichern
If Err.Number 0 Then _
ErrListe "Fehler", "Save", _
aStrFN(zz), Err.Number, Err.Description
.Close False ' Schließen
End If
End With
Else
ErrListe "Fehler", "Open", _
aStrFN(zz), Err.Number, Err.Description
On Error GoTo 0
End If
End If
Next zz
Application.StatusBar = False
If lngErr > 0 Then
ReDim Preserve arrErr(1 To 5, 1 To lngErr)
ThisWorkbook.Worksheets.Add
Cells(2, 1).Resize(UBound(arrErr, 2), UBound(arrErr)) = _
Application.Transpose(arrErr)
End If
With Application
.EnableEvents = True
.Calculation = myCalC
.ScreenUpdating = True
.DisplayStatusBar = blnDisp
End With
End Sub
Sub ErrListe(strArt As String, strBei As String, _
strFile As String, lngNum As Long, strDesc As String)
lngErr = lngErr + 1
If lngErr > UBound(arrErr, 2) Then _
ReDim Preserve arrErr(1 To 5, 1 To 2 * UBound(arrErr, 2))
arrErr(1, lngErr) = strArt
arrErr(2, lngErr) = strBei
arrErr(3, lngErr) = strFile
arrErr(4, lngErr) = lngNum
arrErr(5, lngErr) = strDesc
End Sub
Function SheetEx(strNam As String) As Boolean
On Error Resume Next
SheetEx = ActiveWorkbook.Sheets(strNam).Index > 0
End Function
Option Explicit
Sub Suchmaschine()
Dim FileArray() As String, strPath As String
Dim LCount As Long
Dim iCalc As Integer, oldStatusBar As Integer
Dim strFehler$
strPath = ThisWorkbook.Path
With Application
oldStatusBar = .DisplayScrollBars
iCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.StatusBar = "Daten werden übertragen, bitte warten..."
'1.Parameter Area
'2.Parameter Ordner, wo soll gesucht werden?
'3.Parameter Datei,* als Platzhalter verwenden,Optional leer ist alle
'4.Parameter mit Unterordner = True, Optional False ist ohne
'5.Parameter Zähler
Suchmaschiene FileArray, strPath, "*.xlsx", False, LCount
If LCount > 0 Then
For LCount = Lbound(FileArray) To Ubound(FileArray)
If FileArray(LCount) <> ThisWorkbook.FullName Then
If Not Load_Tab_In_WB(Tabelle1, FileArray(LCount)) Then
strFehler$ = _
Right$(FileArray(LCount), Len(FileArray(LCount)) - InStrRev(FileArray(LCount), "\")) & vbCr
End If
End If
Next LCount
End If
.Calculation = iCalc
.DisplayStatusBar = oldStatusBar
.StatusBar = False
.ScreenUpdating = True
.EnableEvents = True
End With 'Application
If strFehler$ <> "" Then
MsgBox "Es sind Fehler aufgetreten in" & vbCr & vbCr & strFehler, vbExclamation
Else
If LCount > 0 Then
MsgBox "Daten wurden fehlerfrei übertragen", vbInformation
Else
MsgBox "Keine Dateien gefunden!", vbExclamation
End If
End If
Erase FileArray
End Sub
Option Explicit
Sub Suchmaschiene(FileArray, SourceFolderName As String, Optional DateiFormat As String = "*.*", _
Optional IncludeSubfolders As Boolean = False, Optional LCount As Long = 0)
Dim FSO As Object, SourceFolder As Object, SubFolder As Object
Dim FileItem
Dim Status As Integer
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(SourceFolderName) Then
Set SourceFolder = FSO.GetFolder(SourceFolderName)
On Error GoTo Err_Zugriff: 'sollte Ordner geschützt sein
For Each FileItem In SourceFolder.Files
If LCase(FileItem) Like LCase(DateiFormat) Then
Redim Preserve FileArray(LCount)
FileArray(LCount) = FileItem
LCount = LCount + 1
End If
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
Suchmaschiene FileArray, SubFolder.Path, DateiFormat, IncludeSubfolders, LCount
Next SubFolder
End If
Else
MsgBox "Ordner nicht gefunden!", vbCritical
End If
Err_Zugriff:
Set FileItem = Nothing: Set SourceFolder = Nothing: Set FSO = Nothing
End Sub
Option Explicit
Function Load_Tab_In_WB(oSH As Worksheet, strFile As String) As Boolean
Dim oWB As Workbook
On Error GoTo ErrorExit:
Set oWB = Workbooks.Open(strFile)
With oWB
oSH.Copy After:=.Sheets(.Sheets.Count)
.Close True
End With
Load_Tab_In_WB = True
Exit Function
ErrorExit:
On Error Resume Next
oWB.Close False
End Function