Makro läuft langsam

  • Excel

Es gibt 2 Antworten in diesem Thema. Der letzte Beitrag () ist von kriisz.

    Makro läuft langsam

    Ich benutuze das folgende Makro, um ein Diagramm darzustellen. Aber es läuft sehr langsam ab. Ich habe große Intervallen angegeben, weil die Daten sind immer unterschiedlich. Manchmal laufen sie bis 1200 und manchmal bis 2000.
    Wie könnte ich das Makro optimieren?

    Vielen Dank im Voraus.

    Lg
    Christian

    Quellcode

    1. Private Sub CommandButton1_Click()
    2. Dim r As Range, c As Range
    3. Set r = Range("a1:a6000")
    4. Application.ScreenUpdating = False
    5. For Each c In r
    6. If Len(c.Text) = 0 Then
    7. c.EntireRow.Hidden = True
    8. Else
    9. c.EntireRow.Hidden = False
    10. End If
    11. Next c
    12. Application.ScreenUpdating = True
    14. Worksheets("Tabelle1").Rows(2).Hidden = True
    16. Dim myChtObj As ChartObject
    17. Dim rngChtData As Range
    18. Dim rngChtXVal As Range
    19. Dim iColumn As Long
    23. ' define chart data
    24. Set rngChtData = Range("'Tabelle1'!$a$1:$i$6000")
    26. ' define chart's X values
    27. With rngChtData
    28. Set rngChtXVal = .Columns(1).Offset(1).Resize(.Rows.Count - 2)
    29. End With
    31. ' add the chart
    32. Set myChtObj = ActiveSheet.ChartObjects.Add _
    33. (Left:=500, Width:=750, Top:=150, Height:=450)
    34. With myChtObj.Chart
    36. ' make an XY chart
    37. .ChartType = xlLine
    39. ' remove extra series
    40. Do Until .SeriesCollection.Count = 0
    41. .SeriesCollection(1).Delete
    42. Loop
    44. ' add series from selected range, column by column
    45. For iColumn = 2 To rngChtData.Columns.Count
    46. With .SeriesCollection.NewSeries
    47. .Values = rngChtXVal.Offset(, iColumn - 1)
    48. .XValues = rngChtXVal
    49. .Name = rngChtData(1, iColumn)
    50. End With
    51. Next
    53. End With
    55. End Sub

    Bei rechenintensiven Makros ist es immer von Vorteil, wenn man die Bildaktualisierung und die Berechnungen solange abschaltet.


    Quellcode

    1. Dim r As Range, c As Range
    2. Set r = Range("a1:a6000")
    3. Application.ScreenUpdating = False
    4. Application.Calculation = xlCalculationManual
    5. For Each c In r
    6. If Len(c.Text) = 0 Then
    7. c.EntireRow.Hidden = True
    8. Else
    9. c.EntireRow.Hidden = False
    10. End If
    11. Next c
    13. Worksheets("Tabelle1").Rows(2).Hidden = True
    14. Dim myChtObj As ChartObject
    15. Dim rngChtData As Range
    16. Dim rngChtXVal As Range
    17. Dim iColumn As Long
    18. ' define chart data
    19. Set rngChtData = Range("'Tabelle1'!$a$1:$i$6000")
    20. ' define chart's X values
    21. With rngChtData
    22. Set rngChtXVal = .Columns(1).Offset(1).Resize(.Rows.Count - 2)
    23. End With
    24. ' add the chart
    25. Set myChtObj = ActiveSheet.ChartObjects.Add _
    26. (Left:=500, Width:=750, Top:=150, Height:=450)
    27. With myChtObj.Chart
    28. ' make an XY chart
    29. .ChartType = xlLine
    30. ' remove extra series
    31. Do Until .SeriesCollection.Count = 0
    32. .SeriesCollection(1).Delete
    33. Loop
    34. ' add series from selected range, column by column
    35. For iColumn = 2 To rngChtData.Columns.Count
    36. With .SeriesCollection.NewSeries
    37. .Values = rngChtXVal.Offset(, iColumn - 1)
    38. .XValues = rngChtXVal
    39. .Name = rngChtData(1, iColumn)
    40. End With
    41. Next
    42. End With
    43. Application.ScreenUpdating = True
    44. Application.Calculation = xlCalculationAutomatic


    Edit:
    Leerzeichen / Tabs sind weg. Überlasse ich Dir :D

    Edit:
    Wenn der Code auf Fehler läuft, dann bleiben die beiden Dinge aus. Also Fehler abfangen und dann wieder einschalten.

    Quellcode

    1. Dim r As Range, c As Range
    2. err.clear
    3. On Error GoTo Fehler
    4. Set r = Range("a1:a6000")
    5. Application.ScreenUpdating = False
    6. Application.Calculation = xlCalculationManual
    7. For Each c In r
    8. If Len(c.Text) = 0 Then
    9. c.EntireRow.Hidden = True
    10. Else
    11. c.EntireRow.Hidden = False
    12. End If
    13. Next c
    15. Worksheets("Tabelle1").Rows(2).Hidden = True
    16. Dim myChtObj As ChartObject
    17. Dim rngChtData As Range
    18. Dim rngChtXVal As Range
    19. Dim iColumn As Long
    20. ' define chart data
    21. Set rngChtData = Range("'Tabelle1'!$a$1:$i$6000")
    22. ' define chart's X values
    23. With rngChtData
    24. Set rngChtXVal = .Columns(1).Offset(1).Resize(.Rows.Count - 2)
    25. End With
    26. ' add the chart
    27. Set myChtObj = ActiveSheet.ChartObjects.Add _
    28. (Left:=500, Width:=750, Top:=150, Height:=450)
    29. With myChtObj.Chart
    30. ' make an XY chart
    31. .ChartType = xlLine
    32. ' remove extra series
    33. Do Until .SeriesCollection.Count = 0
    34. .SeriesCollection(1).Delete
    35. Loop
    36. ' add series from selected range, column by column
    37. For iColumn = 2 To rngChtData.Columns.Count
    38. With .SeriesCollection.NewSeries
    39. .Values = rngChtXVal.Offset(, iColumn - 1)
    40. .XValues = rngChtXVal
    41. .Name = rngChtData(1, iColumn)
    42. End With
    43. Next
    44. End With
    45. Fehler:
    47. If Err.Number <> 0 Then
    48. MsgBox Err.Description, vbCritical + vbOKOnly, "Fehler: " & Err.Number
    49. Err.Clear
    50. End If
    51. On Error GoTo 0
    52. Application.ScreenUpdating = True
    53. Application.Calculation = xlCalculationAutomatic


    Gruß
    Peterfido

    Keine Unterstützung per PN!

Facebook
Telefonspende