Tabellenblätter kopieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub alle_Dateien_Verzeichnis() Dim strPath$, strExt$, strFile$, TB$ strPath = "C:\Temp\" 'Pfad des Verzeichnisses ggf. anpassen strExt = "*.xls" 'Dateiextension ggf. anpassen TB = "DerName" ' das zu kopierende Blatt If strPath = "" Then Exit Sub Else Application.ScreenUpdating = False strFile = Dir(strPath & strExt) Do While Len(strFile) > 0 Workbooks.Open Filename:=strPath & strFile On Error GoTo Fehler ' wenn Blatt nicht enthalten Workbooks(strFile).Sheets(TB).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) Sheets(TB).Cells.Copy Sheets(TB).Cells.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False Application.CutCopyMode = False [A1].Select 'Umbenennen der Blattes ActiveSheet.Name = TB & " " & Application.Substitute(strFile, ".xls", "") weiter: Workbooks(strFile).Close savechanges:=False strFile = Dir() ' nächste Datei Loop Application.ScreenUpdating = True End If Exit Sub Fehler: If Err.Number = 9 Then Err.Clear MsgBox "Gewünschtes Blatt ist in Datei '" & strFile & "' nicht enthalten!" GoTo weiter End If End Sub

Hallo nochmal
lag scheinbar am Errorhandler:
so klappt es bei mir:


Sub alle_Dateien_Verzeichnis()
Dim strPath$, strExt$, strFile$, TB$
strPath = "C:\Temp\" 'Pfad des Verzeichnisses ggf. anpassen
strExt = "*.xls"       'Dateiextension ggf. anpassen
TB = "DerName" ' das zu kopierende Blatt
If strPath = "" Then
Exit Sub
Else
Application.ScreenUpdating = False
strFile = Dir(strPath & strExt)
On Error Resume Next ' wenn Blatt nicht enthalten
Do While Len(strFile) > 0
Workbooks.Open Filename:=strPath & strFile
Workbooks(strFile).Sheets(TB).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
If Err.Number = 9 Then GoTo Fehler
Sheets(TB).Cells.Copy
Sheets(TB).Cells.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
[A1].Select
'Umbenennen der Blattes
ActiveSheet.Name = TB & " " & Application.Substitute(strFile, ".xls", "")
weiter:
Workbooks(strFile).Close savechanges:=False
strFile = Dir() ' nächste Datei
Loop
Application.ScreenUpdating = True
End If
Exit Sub
Fehler:
Err.Clear
MsgBox "Gewünschtes Blatt ist in Datei '" & strFile & "' nicht enthalten!"
GoTo weiter
End Sub

Gruß Uwe

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread