Option Explicit
'<<< A N P A S S E N >>>
Private Const c_VERZEICHNIS = D:\00_TestExcel
Private Const c_APPENDIX = .xls
'<<< A N P A S S E N E N D E >>>
Sub Excel_Makro_AktivesBltInAlleXLSEinesVerzKopieren()
->Dateien im Verzeichnis feststellen
Dim ws As Worksheet, wb As Workbook
Dim fso As Object, fDir As Object, fFiles As Object, fFile As Object
Dim sName As String
Dim bGeoeffnet As Boolean
->zu kopierendes Arbeitsblatt setzen
Set ws = ThisWorkbook.ActiveSheet
Set fso = CreateObject(Scripting.FileSystemObject)
Set fDir = fso.GetFolder(c_VERZEICHNIS)
Set fFiles = fDir.Files
For Each fFile In fFiles
sName = fFile.Name
->Name ungleich eigener Name
If ThisWorkbook.Name <> sName Then
->Arbeitsmappe .xls ?
If LCase(Right(fFile.Name, Len(c_APPENDIX))) = LCase(c_APPENDIX) Then
->prüfen, ob Datei bereits geöffnet
bGeoeffnet = False
For Each wb In Workbooks
If wb.Name = sName Then bGeoeffnet = True: Exit For
Next
->Arbeitsmappe öffnen, wenn noch nicht geoeffnet
If Not bGeoeffnet Then
Set wb = Nothing
On Error Resume Next
Set wb = Workbooks.Open(c_VERZEICHNIS & Application.PathSeparator & sName)
On Error GoTo 0
End If
If wb Is Nothing Then
MsgBox Datei konnte nicht geöffnet werden: & vbLf & vbLf & sName
Else
->Blatt kopieren
ws.Copy After:=wb.Worksheets(wb.Worksheets.Count)
->war Datei geöffnet ?
Application.DisplayAlerts = False
If bGeoeffnet Then
->Datei speichern
wb.Save
Else
->Datei schliessen mit Speichern
wb.Close Savechanges:=True
End If
Application.DisplayAlerts = True
End If
End If
End If
Next
AUFRAEUMEN:
Set ws = Nothing: Set wb = Nothing
Set fso = Nothing: Set fDir = Nothing: Set fFiles = Nothing: Set fFile = Nothing
End Sub
