AW: Code sorgt für 99%CPU Last und endet nicht?!?
13.08.2008 13:19:25
Lauren
Mahlzeit zusammen,
kann es sein, dass der Code von mir etwas zwischenspeichert und dann träge wird?!?!
Bei manchen Tabellenblättern huscht es ohne probleme in nullkommanix durch und bei anderen mit ca. 17000 Zeilen brauch er ne weile, verstehe ich ja soweit.
Aber dann kommt wieder ein Tabellenblatt mit nur 400 Zeilen und es braucht wieder eeeeeewig bis er die paar Rechnungen macht
Mein Code:
Sub Duplikatgruppierung()
' Duplikatgruppierung Makro
' Makro am 06.08.2008
' Löschen der Zeile wenn in Spalte D,E,F,G eine 0 steht
Dim i
For i = Cells(Rows.Count, 4).End(xlUp).Row To 1 Step -1
On Error Resume Next
If Cells(i, 4).Value = "0" Then
Rows(i).Delete
End If
Next
For i = Cells(Rows.Count, 5).End(xlUp).Row To 1 Step -1
On Error Resume Next
If Cells(i, 5).Value = "0" Then
Rows(i).Delete
End If
Next
For i = Cells(Rows.Count, 6).End(xlUp).Row To 1 Step -1
On Error Resume Next
If Cells(i, 6).Value = "0" Then
Rows(i).Delete
End If
Next
For i = Cells(Rows.Count, 7).End(xlUp).Row To 1 Step -1
On Error Resume Next
If Cells(i, 7).Value = "0" Then
Rows(i).Delete
End If
Next
For i = Cells(Rows.Count, 8).End(xlUp).Row To 1 Step -1
On Error Resume Next
If Cells(i, 8).Value = "0" Then
Rows(i).Delete
End If
Next
' Prüfung auf >= 3
Dim lngZeile As Long
For lngZeile = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If Cells(lngZeile, 1).Value Cells(lngZeile - 1, 1).Value Then
Rows(lngZeile & ":" & lngZeile + 2).Insert
End If
Next
Rows("2:4").Select
Selection.Delete Shift:=xlUp
Range("A2").Select
' Formatieriung
Columns("E:E").Select
Selection.Insert Shift:=xlToRight
Range("E1").Select
ActiveCell.FormulaR1C1 = "anual 1"
Columns("G:G").Select
Selection.Insert Shift:=xlToRight
Range("G1").Select
ActiveCell.FormulaR1C1 = "anual 2"
Columns("I:I").Select
Selection.Insert Shift:=xlToRight
Range("I1").Select
ActiveCell.FormulaR1C1 = "anual 3"
Range("A1").Select
ActiveCell.Offset(0, 12).Select
ActiveCell.FormulaR1C1 = "Produkt 1"
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "Produkt 2"
Range("A1").Select
End Sub
Sub Jahreswerte()
Dim LetzteZeile1 As Long, Zeile1 As Long, Suchbegriff As Long
LetzteZeile1 = Range("C65536").End(xlUp).Row
LetzteZeile1 = LetzteZeile1 + 1
' Produkte der Multiplikationen
Dim Zeilen As Long
Zeilen = Cells(Rows.Count, 1).End(xlUp).Row
Range("M2:M" & Zeilen).FormulaR1C1 = "=IF(COUNTIF(C[-12],RC[-12])>=3,RC[-3]*RC[-9],"""")"
Range("N2:N" & Zeilen).FormulaR1C1 = "=IF(COUNTIF(C[-13],RC[-13])>=3,RC[-3]*RC[-10],"""")"
' Bildung der Jahreswerte
' Summe wenn >= 3
With Range("D2:D" & Cells(Rows.Count, 1).End(xlUp).Row + 1)
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = _
"=IF(R[-1]C1="""",TRUE,IF(COUNTIF(C1,R[-1]C1)RC[-4],RC[-4]="""",RC[-2]""""),RC[-1]/COUNTIF(C[ _
_
-4],R[-1]C[-4])*12,"""")"
Selection.AutoFill Destination:=Range("E2:E" & LetzteZeile1), Type:=xlFillDefault
' Summe 1
With Range("F2:F" & Cells(Rows.Count, 1).End(xlUp).Row + 1)
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = _
"=IF(R[-1]C1="""",TRUE,IF(COUNTIF(C1,R[-1]C1)RC[-6],RC[-6]="""",RC[-4]""""),RC[-1]/COUNTIF( _
_
C1,R[-1]C[-6])*12,"""")"
Selection.AutoFill Destination:=Range("G2:G" & LetzteZeile1), Type:=xlFillDefault
' Summe 2
With Range("H2:H" & Cells(Rows.Count, 1).End(xlUp).Row + 1)
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = _
"=IF(R[-1]C1="""",TRUE,IF(COUNTIF(C1,R[-1]C1)RC[-8],RC[-8]="""",RC[-6]""""),RC[-1]/COUNTIF( _
_
C1,R[-1]C[-8])*12,"""")"
Selection.AutoFill Destination:=Range("I2:I" & LetzteZeile1), Type:=xlFillDefault
'Next ws
Range("A1").Select
End Sub
Sub auswertung()
Dim LetzteZeile As Long, Zeile1 As Long, Suchbegriff As Long
LetzteZeile = Range("A65536").End(xlUp).Row
LetzteZeile = LetzteZeile + 4
Range("A" & LetzteZeile).Select
ActiveCell.Offset(0, 4).Select
ActiveCell.Value = "abcd"
ActiveCell.Offset(0, 2).Select
ActiveCell.Value = "efgh"
ActiveCell.Offset(0, 2).Select
ActiveCell.Value = "ijklm"
With ActiveCell
Range(.Offset(0, 0), .Offset(0, -7)).Select
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Font.Bold = True
Range("A" & LetzteZeile).Select
ActiveCell.Offset(1, 3).Select
ActiveCell.Value = "SUM: "
Selection.Font.Bold = True
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "AVG: "
Selection.Font.Bold = True
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "MIN: "
Selection.Font.Bold = True
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "MAX: "
Selection.Font.Bold = True
LetzteZeile = LetzteZeile - 3
ActiveCell.Offset(-3, 1).Select
ActiveCell.Formula = "=sum(E2:E" & LetzteZeile & ")/1000"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "=sum(G2:G" & LetzteZeile & ")/1000"
ActiveCell.Offset(0, 2).Select
ActiveCell.Formula = "=sum(I2:I" & LetzteZeile & ")/1000"
Columns("E:N").EntireColumn.AutoFit
End Sub
ich führe die schritte bzw. makros jetzt einzeln aus und mal geht es schnell und wenn es einmalewig gedauert hat, dauert es bei den darauffolgenden Berechnungen auch immer eeeeewig.
Jemand ne Idee woren es liegen könnte?