Geschwindigkeit
Dieterlem
Hallo Excelfreunde,
ich habe eine Datei, in der ich ein Organigramm erstellen will. Dazu habe ich ein Ausgangsorganigramm (Hilfsorganigramm) in der ich die Werte anhand Matrixformeln einlese. Die Anzahl der Zeilen und Spalten ist variabel. Damit ich das Organigramm ohne Leerzeilen und -spalten angezeigt bekomme kopiere ich das Ausgangsorganigramm in einen unteren Teil des Sheets und entferne die Formeln. Danach wird Zelle für Zelle überprüft, ob ein Eintrag vorhanden ist. Falls nicht wird sie gelöscht.
Das ganze funktioniert auch. Jedoch benötigt der PC ca. 20 Minuten dafür. Die CPU Auslastung ist bei 90% (Task-Manager).
Ich wollte die Datei anhängen. Jedoch ist die Datei trotz Reduzierung immer noch zu groß für den Upload (>300KB).
Kann mir jemand einen Tipp geben, warum die Berechnung so lange dauert?
Gruß
Dieterlem
Option Explicit
Sub EBM_Organigramm(wsh As Byte)
Dim Ze As Integer
Dim Sp As Byte
Dim letzte As Integer
Dim Start As Integer
Dim Ze2 As Integer
Dim letzteSp As Integer
Dim letzteZe As Integer
Dim PrintBereich As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Sheets(wsh)
'Organigramm1 zu Organigramm2 kopieren-----------------
.Rows("500:1000").Delete Shift:=xlUp 'altes löschen
Application.CutCopyMode = False
.Range("C10:AK222").Copy 'Ausgangsorganigramm kopieren (mit Matrixformeln)
.Activate
.Range("C510").Select
ActiveSheet.Paste 'Ausgangsorganigramm einfügen
Application.CutCopyMode = False
' nochmal kopieren u einfügen = nur Werte (keine Formeln)
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
'Das untere Organigramm anpassen, damit keine Leerzeilen (mit ~ markiert) stehen-----
'Überflüssige Zellen (steht ein ~ drin) löschen--------------------------------------------- _
'Kp Führung-------------------
letzte = 525
Start = 530 'mit den TE's unterhalb der Führung
For Ze = 510 To letzte
If .Cells(Ze, 3) = "~" Then
.Range(.Cells(Ze, 2), .Cells(Ze, 38)).Delete Shift:=xlUp
Ze = Ze - 1
letzte = letzte - 1
Start = Start - 1
End If
If Ze = letzte Then Exit For
Next Ze
'1. Spalte (100)-----------------------
letzte = 721
If .Cells(Start, 3) = "~" Then 'Wenn keine TE eingetragen, dann kpl Kasten löschen
.Range(.Cells(Start - 3, 3), .Cells(letzte, 6)).Delete Shift:=xlUp
GoTo SPALTE2
End If
For Ze = Start To letzte
If .Cells(Ze, 3) = "~" Then
.Range(.Cells(Ze, 3), .Cells(Ze, 5)).Delete Shift:=xlUp
Ze = Ze - 1
letzte = letzte - 1
End If
If Ze = letzte Then Exit For
Next Ze
letzteZe = letzte
SPALTE2:
'2. Spalte (200)-----------------------
letzte = 721
If .Cells(Start, 7) = "~" Then
.Range(.Cells(Start - 3, 6), .Cells(letzte, 10)).Delete Shift:=xlUp
GoTo SPALTE3
End If
For Ze = Start To letzte
If .Cells(Ze, 7) = "~" Then
.Range(.Cells(Ze, 7), .Cells(Ze, 9)).Delete Shift:=xlUp
Ze = Ze - 1
letzte = letzte - 1
End If
If Ze = letzte Then Exit For
Next Ze
SPALTE3:
'3. Spalte (300)-----------------------
letzte = 721
If .Cells(Start, 11) = "~" Then
.Range(.Cells(Start - 3, 10), .Cells(letzte, 14)).Delete Shift:=xlUp
GoTo SPALTE4
End If
For Ze = Start To letzte
If .Cells(Ze, 11) = "~" Then
.Range(.Cells(Ze, 11), .Cells(Ze, 13)).Delete Shift:=xlUp
Ze = Ze - 1
letzte = letzte - 1
End If
If Ze = letzte Then Exit For
Next Ze
SPALTE4:
'4. Spalte (400)-----------------------
letzte = 721
If .Cells(Start, 15) = "~" Then
.Range(.Cells(Start - 3, 14), .Cells(letzte, 18)).Delete Shift:=xlUp
GoTo SPALTE5
End If
For Ze = Start To letzte
If .Cells(Ze, 15) = "~" Then
.Range(.Cells(Ze, 15), .Cells(Ze, 17)).Delete Shift:=xlUp
Ze = Ze - 1
letzte = letzte - 1
End If
If Ze = letzte Then Exit For
Next Ze
SPALTE5:
'5. Spalte (500)-----------------------
letzte = 721
If .Cells(Start, 19) = "~" Then
.Range(.Cells(Start - 3, 18), .Cells(letzte, 22)).Delete Shift:=xlUp
GoTo SPALTE6
End If
For Ze = Start To letzte
If .Cells(Ze, 19) = "~" Then
.Range(.Cells(Ze, 19), .Cells(Ze, 21)).Delete Shift:=xlUp
Ze = Ze - 1
letzte = letzte - 1
End If
If Ze = letzte Then Exit For
Next Ze
SPALTE6:
'6. Spalte (600)-----------------------
letzte = 721
If .Cells(Start, 23) = "~" Then
.Range(.Cells(Start - 3, 22), .Cells(letzte, 26)).Delete Shift:=xlUp
GoTo SPALTE7
End If
For Ze = Start To letzte
If .Cells(Ze, 23) = "~" Then
.Range(.Cells(Ze, 23), .Cells(Ze, 25)).Delete Shift:=xlUp
Ze = Ze - 1
letzte = letzte - 1
End If
If Ze = letzte Then Exit For
Next Ze
SPALTE7:
'7. Spalte (700)-----------------------
letzte = 721
If .Cells(Start, 27) = "~" Then
.Range(.Cells(Start - 3, 26), .Cells(letzte, 30)).Delete Shift:=xlUp
GoTo SPALTE8
End If
For Ze = Start To letzte
If .Cells(Ze, 27) = "~" Then
.Range(.Cells(Ze, 27), .Cells(Ze, 29)).Delete Shift:=xlUp
Ze = Ze - 1
letzte = letzte - 1
End If
If Ze = letzte Then Exit For
Next Ze
SPALTE8:
'8. Spalte (800)-----------------------
letzte = 721
If .Cells(Start, 31) = "~" Then
.Range(.Cells(Start - 3, 30), .Cells(letzte, 34)).Delete Shift:=xlUp
GoTo SPALTE9
End If
For Ze = Start To letzte
If .Cells(Ze, 31) = "~" Then
.Range(.Cells(Ze, 31), .Cells(Ze, 33)).Delete Shift:=xlUp
Ze = Ze - 1
letzte = letzte - 1
End If
If Ze = letzte Then Exit For
Next Ze
SPALTE9:
'9. Spalte (900)-----------------------
letzte = 721
If .Cells(Start, 35) = "~" Then
.Range(.Cells(Start - 3, 34), .Cells(letzte, 37)).Delete Shift:=xlUp
GoTo SPALTE10
End If
For Ze = Start To letzte
If .Cells(Ze, 35) = "~" Then
.Range(.Cells(Ze, 35), .Cells(Ze, 37)).Delete Shift:=xlUp
Ze = Ze - 1
letzte = letzte - 1
End If
If Ze = letzte Then Exit For
Next Ze
SPALTE10:
End With
'Kästen wieder schließen--------------------------------------------------
'Kasten Führung-------------------------------------
For Ze = 510 To 521
If Sheets(wsh).Cells(Ze, 3) = "" Then
Sheets(wsh).Range(Sheets(wsh).Cells(Ze, 3), Sheets(wsh).Cells(Ze, 5)).Select
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Exit For
End If
Next Ze
Application.ScreenUpdating = True
Application.ScreenUpdating = False
'1. bis 9. Spalte (100 - 900)-----------------------
For Sp = 3 To 35 Step 4 'nur befüllte Spalten verwenden
For Ze = Start To 721
If Sheets(wsh).Cells(Ze, Sp).Interior.ColorIndex = 36 Then
letzte = Ze + 10
For Ze2 = Ze To letzte 'ermitteln wie viele Geräte im Kasten
If Sheets(wsh).Cells(Ze2, Sp) = "" Then Exit For
Next Ze2
Sheets(wsh).Range(Sheets(wsh).Cells(Ze2, Sp), Sheets(wsh).Cells(Ze2, Sp + 2)). _
Select
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Ze = Ze2 + 1 'Werte überspringen (Geschwindigkeit)
End If
Next Ze
Next Sp
'Organigramm2 Anpassen-------------------------------------------------------------------------- _
With Sheets(wsh)
letzteZe = .Cells.Find(What:="*", After:=Range("A1"), _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 'letzte benutzte _
Zeile
letzteSp = .Cells(Start, 256).End(xlToLeft).Column 'letzte benutzte _
Spalte
.PageSetup.Orientation = xlLandscape 'Anpassen: _
Querformat
.PageSetup.Draft = False
' .PageSetup.PaperSize = xlPaperA3 'Anpassen: DINA3
.PageSetup.BlackAndWhite = False
.PageSetup.Zoom = False
.PageSetup.FitToPagesWide = 1 'Anpassen: eine _
Seite breit
.PageSetup.FitToPagesTall = 1 'Anpassen: eine _
Seite hoch
.Columns("A:A").EntireColumn.Hidden = True
.Rows("1:507").EntireRow.Hidden = True
.Columns("B:B").ColumnWidth = 3.71
.Rows("510:510").RowHeight = 19.5 'Höhe Chef _
einstellen
.Rows("507:1000").Interior.ColorIndex = 24 'Zellen einfärben ( _
Hintergrund)
.Rows(letzteZe + 2 & ":65536").Hidden = True
If letzteSp >= 26 Then
PrintBereich = Mid(.Columns(letzteSp + 2).Address, 2, 2) & ":IV"
.Columns(PrintBereich).Hidden = True
ElseIf letzteSp = 25 Then
PrintBereich = Mid(.Columns(letzteSp + 2).Address, 2, 2) & ":IV"
.Columns(PrintBereich).Hidden = True
Else
PrintBereich = Mid(.Columns(letzteSp + 2).Address, 2, 1) & ":IV"
.Columns(PrintBereich).Hidden = True
End If
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub