Tabellenblätter kopieren
08.07.2005 08:45:41
pb
ich benutze folgendes Makro, um aus Dateien in einem Verzeichnis jeweils ein Blatt auszulesen und in eine neue Datei zu kopieren.
In der neuen Datei will ich nur Werte, keine Formate etc. haben. Ich bekomme aber immer die Formate mitgeliefert, was das ganze sehr langsam macht und oft zum Absturz bringt. Für eine Lösung wäre ich sehr dankbar.
Sub Tabelle()
Dim strPath$, strExt$, strFile$, TB$
strPath = "\" 'Pfad des Verzeichnisses
strExt = "*.xls" 'Dateiextension
TB = "" ' 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ß
pb