lange Laufzeit / kann ich kürzen ?

[Wexel]

Hallo zusammen,

ich habe u.g. Makro erstellt. Dieses funzt auch, allerdings dauert das alles sehr sehr lange > 2min

Kann ich das Makro optimieren ??

Code:

Sub aktualisieren_gelb()


Range("J8").Select
Do
If ActiveCell.Value = 1 Or ActiveCell.Offset(0, 29) = 1 Then 'Abtei
ActiveCell.Offset(0, 29) = 1
Else
ActiveCell.Offset(0, 29) = ""
End If
If ActiveCell.Value = 1 Or ActiveCell.Offset(0, 30) = 1 Then 'Freim
ActiveCell.Offset(0, 30) = 1
Else
ActiveCell.Offset(0, 30) = ""
End If
If ActiveCell.Value = 1 Then 'Rett
ActiveCell.Offset(0, 40) = 1
Else
ActiveCell.Offset(0, 40) = ""
End If
If ActiveCell.Value = 1 Then 'Al Eq
ActiveCell.Offset(0, 41) = 1
Else
ActiveCell.Offset(0, 41) = ""
End If
ActiveCell.Offset(1, 0).Select '1 Zelle nach unten
Loop Until ActiveCell.Offset(0, -8) = ""

                'Vorwahl Ar
                Range("H8").Select
                Do
                If ActiveCell.Value = 1 Then
                ActiveCell.Offset(0, 31) = 1
                End If
                If ActiveCell.Value = 1 Then
                ActiveCell.Offset(0, 44).Interior.ColorIndex = 6 'gelb
                Else
                ActiveCell.Offset(0, 44).Interior.ColorIndex = 0 'neutral
                End If
                If ActiveCell.Value = 1 Then
                ActiveCell.Offset(0, 45).Interior.ColorIndex = 6 'gelb
                Else
                ActiveCell.Offset(0, 45).Interior.ColorIndex = 0 'neutral
                End If
                ActiveCell.Offset(1, 0).Select '1 Zelle nach unten
                Loop Until ActiveCell.Offset(0, -6) = ""

                            'Springe nach externe Mitarbeiter
                            Range("Ao8").Select
                            Do
                            If ActiveCell.Value >= 1 Then
                            ActiveCell.Offset(0, 1).Interior.ColorIndex = 6 'gelb
                            ActiveCell.Offset(0, 2).Interior.ColorIndex = 6 'gelb
                            ActiveCell.Offset(0, 3).Interior.ColorIndex = 6 'gelb
                            ActiveCell.Offset(0, 4).Interior.ColorIndex = 6 'gelb
                            ActiveCell.Offset(0, 5).Interior.ColorIndex = 6 'gelb
                            ActiveCell.Offset(0, 6).Interior.ColorIndex = 6 'gelb
                            ActiveCell.Offset(0, 7).Interior.ColorIndex = 6 'gelb
                            ActiveCell.Offset(0, 8).Interior.ColorIndex = 6 'gelb
                            Else
                            ActiveCell.Offset(0, 1).Interior.ColorIndex = 0 'neutral
                            ActiveCell.Offset(0, 2).Interior.ColorIndex = 0 'neutral
                            ActiveCell.Offset(0, 3).Interior.ColorIndex = 0 'neutral
                            ActiveCell.Offset(0, 4).Interior.ColorIndex = 0 'neutral
                            ActiveCell.Offset(0, 5).Interior.ColorIndex = 0 'neutral
                            ActiveCell.Offset(0, 6).Interior.ColorIndex = 0 'neutral
                            ActiveCell.Offset(0, 7).Interior.ColorIndex = 0 'neutral
                            ActiveCell.Offset(0, 8).Interior.ColorIndex = 0 'neutral
                            End If
                            ActiveCell.Offset(1, 0).Select '1 Zelle nach unten
                            Loop Until ActiveCell.Offset(0, -39) = ""


'Springe nach oben
Range("A8").Select

'Lösche Daten Zwischenablage
Application.CutCopyMode = False

End Sub

[Gast 123]

Hallo

probier mal den geaenderten Code, da habe ich auf Select verzichtet und schalte den Bildschirm ab.    (ungetestet !!)
Diese Schreibweise mag für Anfaenger ungewöhnlich sein, ist aber meines Wissens effektiver.  Rückmeldung waere nett.
Weitergeschaltet wird über z als Zaehler, die 1. Adresse bleibt dabei über With Range() als Basisadresse bestehen.

mfg  Gast 123

Code:

Sub aktualisieren_gelb()
Dim z As Long

Application.ScreenUpdating = False
With Range("J8"):  z = 0
  Do
    If .Offset(z, 0) = 1 Or .Offset(z, 29) = 1 Then 'Abtei
    .Offset(z, 29) = 1
    Else
    .Offset(z, 29) = ""
    End If
    If .Offset(z, 0) = 1 Or .Offset(z, 30) = 1 Then 'Freim
    .Offset(z, 30) = 1
    Else
    .Offset(z, 30) = ""
    End If
    If .Offset(z, 0) = 1 Then 'Rett
    .Offset(z, 40) = 1
    Else
    .Offset(z, 40) = ""
    End If
    If .Offset(z, 0) = 1 Then 'Al Eq
    .Offset(z, 41) = 1
    Else
    .Offset(z, 41) = ""
    End If
    z = z + 1  '1 Zelle nach unten
  Loop Until .Offset(z, -8) = ""
End With


'Vorwahl Ar
With Range("H8"):  z = 0
  Do
    If .Offset(z, 0) = 1 Then
    .Offset(z, 31) = 1
    End If
    If .Offset(z, 0) = 1 Then
    .Offset(z, 44).Interior.ColorIndex = 6 'gelb
    Else
    .Offset(z, 44).Interior.ColorIndex = 0 'neutral
    End If
    If .Offset(z, 0) = 1 Then
    .Offset(z, 45).Interior.ColorIndex = 6 'gelb
    Else
    .Offset(z, 45).Interior.ColorIndex = 0 'neutral
    End If
    z = z + 1  '1 Zelle nach unten
  Loop Until .Offset(z, -6) = ""
End With


'Springe nach externe Mitarbeiter
With Range("Ao8"):  z = 0
    Do
    If .Offset(z, 0) >= 1 Then
    .Offset(z, 1).Resize(1, 8).Interior.ColorIndex = 6 'gelb
    Else
    .Offset(z, 1).Resize(1, 8).Interior.ColorIndex = 0 'neutral
    End If
    z = z + 1  '1 Zelle nach unten
    Loop Until .Offset(z, -39) = ""
End With
End Sub

[Steffl]

Hallo,

bin zwar zu spät aber da ich mir die Mühe gemacht habe

Code:

Sub aktualisieren_gelb()
Dim lngC As Long

Range("J8").Select
Do
If ActiveCell.Value = 1 Or ActiveCell.Offset(0, 29) = 1 Then 'Abtei
ActiveCell.Offset(0, 29) = 1
Else
ActiveCell.Offset(0, 29) = ""
End If
If ActiveCell.Value = 1 Or ActiveCell.Offset(0, 30) = 1 Then 'Freim
ActiveCell.Offset(0, 30) = 1
Else
ActiveCell.Offset(0, 30) = ""
End If
If ActiveCell.Value = 1 Then 'Rett
ActiveCell.Offset(0, 40).Resize(, 2) = 1
Else
ActiveCell.Offset(0, 40).Resize(, 2) = ""
End If
ActiveCell.Offset(1, 0).Select '1 Zelle nach unten
Loop Until ActiveCell.Offset(0, -8) = ""

                'Vorwahl Ar
                lngC = 8
'                Range("H8").Select
                Do
                  If Cells(lngC, 8).Value = 1 Then
                     Cells(lngC, 8).Offset(0, 31) = 1
                  End If
                  If Cells(lngC, 8).Value = 1 Then
                     Cells(lngC, 8).Offset(0, 44).Resize(, 2).Interior.ColorIndex = 6 'gelb
                  Else
                     Cells(lngC, 8).Offset(0, 44).Resize(, 2).Interior.ColorIndex = 0 'neutral
                  End If
                  lngC = lngC + 1 '1 Zelle nach unten
                Loop Until Cells(lngC, 8).Offset(0, -6) = ""

                            'Springe nach externe Mitarbeiter
                            lngC = 8
'                            Range("Ao8").Select
                            Do
                              If Cells(lngC, 41).Value >= 1 Then
                                 Cells(lngC, 41).Offset(0, 1).Resize(, 8).Interior.ColorIndex = 6 'gelb
                              Else
                                 Cells(lngC, 41).Offset(0, 1).Resize(, 8).Interior.ColorIndex = 0 'neutral
                              End If
                              lngC = lngC + 1 '1 Zelle nach unten
                            Loop Until Cells(lngC, 41).Offset(0, -39) = ""


'Springe nach oben
Range("A8").Select

'Lösche Daten Zwischenablage
Application.CutCopyMode = False

End Sub

[Wexel]

Hallo GAst123, hallo Stefan.

Habe eben beide Makros getestet. Eines Vorweg, vielen Dank, funktionieren beide !

Wobei das vom Stefan ähnlich "langsam" ist wie meines.

Der absolute hit ist das Makro von Gast 123. echt spitze.

Eine Frage dazu noch.

Gibt es eine Möglichkeit in einem regelmäßigen Intervall, sagen wir alle 3-4 Minuten das Makro automatisch zu starten, Sozusagen einauto Update ?

Danke Wexel

[Gast 123]

Hallo Wexel

ich bedanke mich für die Rückmeldung und freue mich das wir die Laufzeit verkürzen konnten.
Zur Frage das Makro als Intervall zu wiederholen muss ich passen.  Vielleicht weiss Stefan Rat.
Es gibt im Internet Lösungen zu diesem Thema. Ich habe es aber nie gebraucht ...

mfg  Gast 123

[Steffl]

Hallo,

schau mal hier vorbei (ist aber ziemlich weit unten). Du solltest den Artikel aber von Anfang an durch lesen.

[Wexel]

Habs so gelöst, damke an Allle

'Auto Aktualisierung 300Sekunden

Application.OnTime Now + TimeSerial(0, 0, 300), "aktualisieren_gelb"