Optimiterungspotentiale
19.12.2007 08:58:00
Salim
ich habe folgendes Makro geschrieben (bitte um ein bisschen Gnade: siehe Level VBA bescheiden ;) )
Der Makro läuft auch. Der einzige negative Punkt ist dass unten links der Satz: Markieren Sie den Zellbereich und drücken Sie die Eingabetaste ständig blinkt. Ich kann es nicht nachvollziehen.
Gruss
Salim
Private Sub CommandButton1_Click()
Dim StBerechnung As Integer
StBerechnung = Application.Calculation ' Berechnungsmodus speichern
Application.Calculation = xlManual ' Berechnungsmodus manuell
Me.Hide
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Worksheets("Tabelle1").Unprotect
Worksheets("Tabelle1").Cells.Replace What:="Tabelle2!", Replacement:="Standardblatt!", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:= _
False
With ThisWorkbook
For Each Worksheet In .Sheets
If Worksheet.Name = "Tabelle2" Then
Sheets("Tabelle2").Delete
End If
Next Worksheet
End With
Sheets("Tabelle3").Copy before:=Sheets("Tabelle1")
Sheets("Tabelle3 (2)").Visible = True
ActiveSheet.Name = "Tabelle2"
With Worksheets("Tabelle2")
ActiveSheet.Unprotect
Dim lSh As Worksheet
With ThisWorkbook
For Each lSh In .Sheets
If .Sheets(lSh.Name).Range("A1").Value = "1" And lSh.Name "2" Then
For i = Cells(Rows.Count, 4).End(xlUp).Row To 1 Step -1
If Cells(i, 4) = "a " Or Cells(i, 4) = "b " Or Cells(i, 4) = "c" Or _
Cells(i, 4) = "d" Or Cells(i, 4) = "e" Or _
Cells(i, 4) = "f" Or Cells(i, 4) = "g" Or _
Cells(i, 4) = "h" Or Cells(i, 4) = "i" Or _
Cells(i, 4) = "j" Or Cells(i, 4) = "k" _
Or Cells(i, 4) = "l" Or Cells(i, 4) = "m" _
Or Cells(i, 4) = "n" Or Cells(i, 4) = "o" _
Or Cells(i, 4) = "p" Or Cells(i, 4) = "q" _
Or Cells(i, 4) = "r" Or Cells(i, 4) = "s" _
Or Cells(i, 4) = "t" Or Cells(i, 4) = "u" _
Or Cells(i, 4) = "v" Or Cells(i, 4) = "w" _
Or Cells(i, 4) = "x" Or Cells(i, 4) = "y" Or Cells(i, 4) = "z" _
Or Cells(i, 4) = "aa" Or Cells(i, 4) = "ab" _
Or Cells(i, 4) = "ac" Or Cells(i, 4) = "ad" _
Or Cells(i, 4) = "ae" Or Cells(i, 4) = "af" _
Or Cells(i, 4) = "ag" Or Cells(i, 4) = "ah" _
Or Cells(i, 4) = "ai" Or Cells(i, 4) = "aj" _
Or Cells(i, 4) = "ak" Or Cells(i, 4) = "al" Then
Rows(i - 1).Copy
Cells(i - 1, 1).EntireRow.Insert
Rows(i - 1).Replace What:="Standardblatt!", Replacement:=lSh.Name & "!", LookAt _
:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Rows(i - 1).Copy
Rows(i - 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Outline.ShowLevels RowLevels:=1
End If
Next i
Application.CutCopyMode = False
End If
Next
End With
For i = Cells(Rows.Count, 4).End(xlUp).Row To 1 Step -1
If Cells(i, 4) = "am" Then
Rows(i).EntireRow.Delete
End If
Next i
For i = Cells(Rows.Count, 4).End(xlUp).Row To 1 Step -1
If Cells(i, 4) = "an" Then
ActiveSheet.HPageBreaks.Add before:=Cells(i - 1, 4)
End If
Next i
End With
Range("D3").Value = Date
Worksheets("Tabelle1").Unprotect
Worksheets("Tabelle1").Cells.Replace What:="Standardblatt!", Replacement:="Tabelle2!", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:= _
False
Worksheets("Tabelle1").EnableOutlining = True
Worksheets("Tabelle1").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingColumns:=True, AllowFiltering:=True, userInterfaceOnly:=True
ActiveSheet.Unprotect
Range("A1:ad1").Select
ActiveWindow.Zoom = True
Range("A1").Select
Dim Ende As Integer
Ende = ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row
With ActiveSheet.PageSetup
.PrintArea = "$c$1:$ad$" & Ende
.PrintTitleRows = "$1:$8"
.FitToPagesWide = 1
.FitToPagesTall = False
.Zoom = False
End With
ActiveSheet.EnableOutlining = True
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingColumns:=True, userInterfaceOnly:=True
Application.Calculation = StBerechnung ' Berechnungsmodus zurück
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub