ich muss in 400 Exceldateien ein Blatt austauschen. Dass Blatt hat in den Dateien immer den selben Namen. Kann ich es irgendwie umgehen, jede einzelne Mappe zu öffnen und dann den Austausch vorzunehmen?
Liebe Grüße
Ralf
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
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort
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
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-LintfortFunction 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