Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.
Clever-Excel-Forum › Office-Anwendungen › Excel v
lange Laufzeit / kann ich kürzen ?

Thema geschlossen 
Baumstrukturmodus
lange Laufzeit / kann ich kürzen ?
Wexel Offline
Benutzer
Registriert seit: 08.10.2017
Version(en): 2017
#1
13.01.2018, 15:07 (Dieser Beitrag wurde zuletzt bearbeitet: 13.01.2018, 17:04 von WillWissen. Bearbeitungsgrund: Makro in Codetags gesetzt )
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
Suchen
Antworten Top
Gast 123 Offline
Benutzer
Registriert seit: 12.03.2016
Version(en): Excel 2003
#2
13.01.2018, 19:04
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
Suchen
Antworten Top
Steffl Offline
Excelanwender
Registriert seit: 11.04.2014
Version(en): Office 2007
#3
13.01.2018, 19:33
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
Gruß Stefan
Win 10 / Office 2016
Suchen
Antworten Top
Wexel Offline
Benutzer
ThreadStarter

Registriert seit: 08.10.2017
Version(en): 2017
#4
14.01.2018, 18:39
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
Suchen
Antworten Top
Gast 123 Offline
Benutzer
Registriert seit: 12.03.2016
Version(en): Excel 2003
#5
15.01.2018, 12:15
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
Suchen
Antworten Top
Steffl Offline
Excelanwender
Registriert seit: 11.04.2014
Version(en): Office 2007
#6
15.01.2018, 12:39
Hallo,

schau mal hier vorbei (ist aber ziemlich weit unten). Du solltest den Artikel aber von Anfang an durch lesen.
Gruß Stefan
Win 10 / Office 2016
Suchen
Antworten Top
Wexel Offline
Benutzer
ThreadStarter

Registriert seit: 08.10.2017
Version(en): 2017
#7
18.01.2018, 19:13
Habs so gelöst, damke an Allle

'Auto Aktualisierung 300Sekunden

Application.OnTime Now + TimeSerial(0, 0, 300), "aktualisieren_gelb"
Suchen
Antworten Top
Thema geschlossen 


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste