Sub BlattTausch() ' UNGETESTET
' Ersetzt in allens xls-Mappen eines Verzeichnisses das Blatt "Telefonverzeichnis"
' durch das Blatt aus der Mappe, in der dieser Code steht
Dim strD As String, wks As Worksheet, lngI As Long
Const strVz As String = "c:\temp\" ' In diesem Verz. liegen die ca. 400 Mappen.
strD = Dir(strVz & "*.xls") ' Alle ca. 400 *xls-Dateien werden bearbeitet.
' Hier könnte man ein Suchmuster einstellen.
While strD > ""
Workbooks.Open strD, 0, True
With ActiveWorkbook
lngI = 0
For Each wks In .Worksheets
If wks.Name = "Telefonverzeichnis" Then
Application.DisplayAlerts = False
lngI = .Index
wks.Delete
Application.DisplayAlerts = True
If lngI = 1 Then
ThisWorkbook.Worksheets("Telefonverzeichnis").Copy before:=.Sheets(1)
Else
ThisWorkbook.Worksheets("Telefonverzeichnis").Copy after:=.Sheets(lngI)
End If
Exit For
End If
Next wks
If lngI = 0 Then MsgBox .Name & vbLf & "ist ohne Blatt 'Telefonverzeichnis'"
End With
strD = Dir()
Wend
End Sub
Sub BlattTausch() ' UNGETESTET
' Ersetzt in allens xls-Mappen eines Verzeichnisses das Blatt "Telefonverzeichnis"
' durch das Blatt aus der Mappe, in der dieser Code steht
Dim strD As String, wks As Worksheet, lngI As Long
Const strVz As String = "c:\temp\" ' In diesem Verz. liegen die ca. 400 Mappen.
strD = Dir(strVz & "*.xls") ' Alle ca. 400 *xls-Dateien werden bearbeitet.
' Hier könnte man ein Suchmuster einstellen.
While strD > ""
Workbooks.Open strD, 0, True
With ActiveWorkbook
lngI = 0
For Each wks In .Worksheets
If wks.Name = "Telefonverzeichnis" Then
Application.DisplayAlerts = False
lngI = .Index
wks.Delete
Application.DisplayAlerts = True
If lngI = 1 Then
ThisWorkbook.Worksheets("Telefonverzeichnis").Copy before:=.Sheets(1)
Else
ThisWorkbook.Worksheets("Telefonverzeichnis").Copy after:=.Sheets(lngI)
End If
Exit For
End If
Next wks
If lngI = 0 Then
MsgBox .Name & vbLf & "ist ohne Blatt 'Telefonverzeichnis'"
.Close False ' hier wird nicht gespeichert
Else
.Close True ' hier werden die Mappen wieder gespeichert
End If
End With
strD = Dir()
Wend
End Sub
Function TabelleTauschen()
Dim fso
Dim QuelleWB As Object
Dim ZielWB As Object
Dim FileVerzeichnis, Filename, Sheetname As String
Dim Tabellenblattgeloescht As Boolean
Dim DateiObjekt As Scripting.File
Sheetname = "Telefonverzeichnis"
FileVerzeichnis = ThisWorkbook.Path
Set fso = CreateObject("Scripting.FileSystemObject")
Set QuelleWB = ThisWorkbook
'for Each
For Each DateiObjekt In fso.GetFolder(FileVerzeichnis).Files
If InStr(DateiObjekt.Name, "xls") > 0 And DateiObjekt.Name "TELEVZ_MAKRO.xls" Then
Set ZielWB = Workbooks.Open(ThisWorkbook.Path & "\" & DateiObjekt.Name)
Tabellenblattgeloescht = False
For i = 1 To ZielWB.Sheets.Count
If InStr(ZielWB.Sheets(i).Name, Sheetname) > 0 Then
ZielWB.Sheets(i).Delete
Tabellenblattgeloescht = True
Exit For
End If
Next
If Tabellenblattgeloescht = True Then
QuelleWB.Activate
QuelleWB.Sheets(Sheetname).Select
QuelleWB.Sheets(Sheetname).Copy
ZielWB.Activate
ZielWB.Paste
ZielWB.Save False
ZielWB.Close
End If
Set ZielWB = Nothing
End If
Next
Set fso = Nothing
End Function
Function TabellenTauschen()
Dim fso
Dim QuelleWB As Object
Dim ZielWB As Object
Dim FileVerzeichnis, Filename, Sheetname As String
Dim Tabellenblattgeloescht As Boolean
Dim DateiObjekt As Scripting.File
Sheetname = "Telefonverzeichnis"
FileVerzeichnis = ThisWorkbook.Path
Set fso = CreateObject("Scripting.FileSystemObject")
Set QuelleWB = ThisWorkbook
For Each DateiObjekt In fso.GetFolder(FileVerzeichnis).Files
If InStr(DateiObjekt.Name, "xls") > 0 And DateiObjekt.Name ThisWorkbook.Name Then
Set ZielWB = Workbooks.Open(ThisWorkbook.Path & "\" & DateiObjekt.Name)
Tabellenblattgeloescht = False
For i = 1 To ZielWB.Sheets.Count
If InStr(ZielWB.Sheets(i).Name, Sheetname) > 0 Then
Application.DisplayAlerts = False
ZielWB.Sheets(i).Delete
Tabellenblattgeloescht = True
Application.DisplayAlerts = True
Exit For
End If
Next
If Tabellenblattgeloescht = True Then
QuelleWB.Activate
QuelleWB.Sheets(Sheetname).Select
QuelleWB.Sheets(Sheetname).Copy Before:=ZielWB.Sheets(1)
ZielWB.Save
End If
ZielWB.Close
Set ZielWB = Nothing
End If
Next
Set fso = Nothing
Set QuelleWB = Nothing
End Function