Wieso dauert der Code 3 Minuten?
08.01.2012 18:12:59
Reinhard
Hallo Matze,
die 3 min erscheinen mir recht lang.
Nimm mal eine neue leere Mappe, NICHT das Original
und rufe dort mal die Prozedur "test" auf.
Bei mir wird ca. 15 sec angezeigt.
Vielleicht habe ich einen Denkfehler im Code, deshalb Frage auf noch offen damit andere klären können
warum du sagst 3 min und ich 15 sec. Habe ich da was falsch "nachgebaut"?
Gruß
Reinhard
Option Explicit
Sub test()
Dim T As Single
Call BlaetterLoeschen
Call BlaetterErzeugen
Call Bed_Format
T = Timer
Call MeineZellen
MsgBox Timer - T
End Sub
Sub MeineZellen()
Dim C As Range, T As Integer
Application.ScreenUpdating = False
With Worksheets("Tabelle1").Range("F13:AJ14,F19:AJ20,F25:AJ26,F33:AJ34,F55:AJ56,F77:AJ78")
On Error Resume Next
For Each C In .SpecialCells(xlCellTypeAllFormatConditions)
On Error GoTo 0
C.Copy
' Schade, mit Array klappt es wohl nicht :-(
'Sheets(Array("Tabelle2", "Tabelle3")).Range(C.Address).PasteSpecial Paste:=xlFormats
For T = 2 To ThisWorkbook.Worksheets.Count
Worksheets(T).Range(C.Address).PasteSpecial Paste:=xlFormats
Next T
Next
Application.CutCopyMode = False
End With
Application.ScreenUpdating = True
'MsgBox "fertig"
End Sub
Sub Bed_Format()
With Worksheets("Tabelle1").Range("F13:AJ14,F19:AJ20,F25:AJ26,F33:AJ34,F55:AJ56,F77:AJ78")
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="=A1>5"
.FormatConditions(1).Interior.ColorIndex = 27
End With
End Sub
Sub BlaetterErzeugen()
While Worksheets.Count 1
Worksheets(2).Delete
Wend
Application.DisplayAlerts = True
End Sub