Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Tabellenblätter kopieren

Forumthread: Tabellenblätter kopieren

Tabellenblätter kopieren
08.07.2005 08:45:41
pb
Hallo Kollegen,
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
Anzeige

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Tabellenblätter kopieren
08.07.2005 16:33:50
Marc
Hallo,
ersetze dieses:
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
duch:
Cells.Copy
Sheets("Tabelle1").Select
Sheets.Add After:=Sheets(1)
If Err.Number = 9 Then GoTo Fehler
Selection.PasteSpecial Paste:=xlValues
Range("A1").Select
Gruß Marc
Anzeige
;

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Entdecke mehr
Finde genau, was du suchst

Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden

Suche nach den besten Antworten
Unsere beliebtesten Threads

Entdecke unsere meistgeklickten Beiträge in der Google Suche

Top 100 Threads jetzt ansehen
Anzeige