Makro "beschleunigen"
11.01.2005 11:01:50
Henri
mein Makro kopiert aus einer anderen Tabelle aus verschiedenen Tabellenblättern verschiedene Bereiche. Leider dauert dieser Vorgang ca. 5min.
Gibt es eine Möglichkeit diesen Ablauf zu beschleunigen. Vielleicht ist mein Code auch nicht so optimal.
grüße
Henri
Sub Import()
Dim strQuelle, strQuellekurz
Dim strZiel
Dim TB As Object
Dim dFilter$
dFilter = "Excel-Dateien(*.xls), *.xls"
ChDrive "U"
ChDir "U:\Eigene Dateien"
MsgBox "Bitte im folgenden Fenster die Quelldatei auswählen!", vbInformation
strZiel = ActiveWorkbook.Name
strQuelle = Application.GetOpenFilename(dFilter)
strQuellekurz = Dir(strQuelle)
If strQuelle = False Then Exit Sub
Application.EnableEvents = False
Workbooks.Open (strQuelle)
Application.EnableEvents = True
strQuellekurz = Dir(strQuelle)
Application.ScreenUpdating = False
For Each TB In Workbooks(strQuellekurz).Sheets
Select Case TB.Name
Case "Januar", "März", "Mai", "Juli", "August", "Oktober", "Dezember"
Workbooks(strQuellekurz).Sheets(TB.Name).Range("D5:F35").Copy
Workbooks(strZiel).Sheets(TB.Name).Range("D5:F35").PasteSpecial Paste:=xlValues
Workbooks(strQuellekurz).Sheets(TB.Name).Range("I5:I35").Copy
Workbooks(strZiel).Sheets(TB.Name).Range("I5:I35").PasteSpecial Paste:=xlValues
Workbooks(strQuellekurz).Sheets(TB.Name).Range("K5:M35").Copy
Workbooks(strZiel).Sheets(TB.Name).Range("K5:M35").PasteSpecial Paste:=xlValues
Case "April", "Juni", "September", "November"
Workbooks(strQuellekurz).Sheets(TB.Name).Range("D5:F34").Copy
Workbooks(strZiel).Sheets(TB.Name).Range("D5:F34").PasteSpecial Paste:=xlValues
Workbooks(strQuellekurz).Sheets(TB.Name).Range("I5:I34").Copy
Workbooks(strZiel).Sheets(TB.Name).Range("I5:I34").PasteSpecial Paste:=xlValues
Workbooks(strQuellekurz).Sheets(TB.Name).Range("K5:M34").Copy
Workbooks(strZiel).Sheets(TB.Name).Range("K5:M34").PasteSpecial Paste:=xlValues
Case "Februar"
Workbooks(strQuellekurz).Sheets(TB.Name).Range("D5:F33").Copy
Workbooks(strZiel).Sheets(TB.Name).Range("D5:F33").PasteSpecial Paste:=xlValues
Workbooks(strQuellekurz).Sheets(TB.Name).Range("I5:I33").Copy
Workbooks(strZiel).Sheets(TB.Name).Range("I5:I33").PasteSpecial Paste:=xlValues
Workbooks(strQuellekurz).Sheets(TB.Name).Range("K5:M33").Copy
Workbooks(strZiel).Sheets(TB.Name).Range("K5:M33").PasteSpecial Paste:=xlValues
End Select
Next TB
Workbooks(strQuellekurz).Close savechanges:=False
Application.ScreenUpdating = True
End Sub
Anzeige