Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1732to1736
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Code Optimierung

Code Optimierung
18.01.2020 07:34:44
kocius
Hallo Zusammen,
brauche Unterstützung bei der Code Optimierung. Es geht um den Button "Median berechnen". Die Laufzeit bei 200 Zeilen dauert etwa 5 min.
Für Eure Hilfe wäre sehr dankbar.
Anbei die Datei:
https://www.herber.de/bbs/user/134495.xlsm
Gruss

11
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Code Optimierung
18.01.2020 08:17:26
Nepumuk
Hallo kocius,
warum berechnest du bis Zeile 200 wenn es nur 35 Datenzeilen sind?
Ändere mal:
For rc = 2 To lr
Gruß
Nepumuk
AW: Code Optimierung
18.01.2020 08:36:20
kocius
Hallo Nepumuk,
danke für Deine schnelle Rückmeldung. Ich habe als Beispiel geschickt, es wird viel mehr an den Zeilen geben und ab 100 Zeilen berechnet er viel zu langsam.
Gruss
AW: Code Optimierung
18.01.2020 09:39:56
Nepumuk
Hallo kocius,
ich habe deinen Code mal ausgemistet:
'sucht Durchführungszeiten zum angegebenem Testfall und speichert diese in einer Tabelle auf dem Tabellenblatt Berechnung
Sub searchandsave()
    
    Dim DatAnfang As Date
    DatAnfang = Now
    
    Dim rngZelle As Range, rngBereich As Range
    Dim tctime
    Dim rowcounter As Long
    Dim berzähler As Long
    Dim mediantime
    
    '############################################################################Schleife
    
    Dim lr As Long 'lastwrittenrow im Reiter "Statistik" 1 Spalte
    Dim rc As Long 'Zeilenzähler
    Dim tc As Long 'Zähler für Tesfall-IDs
    
    Dim lngSpalte As Long
    Dim a As Long
    Dim avntValues As Variant
    Dim FirtsSearchTestcaseid As String
    
    '========================NEU Anfang========================
    Dim SearchTestcaseid As Range
    '========================NEU Ende========================
    
    DisableAppFeedback
    
    '** Spalte, die auf Leerzeichen geprüft werden soll
    lngSpalte = 1
    avntValues = Range(Cells(2, lngSpalte), Cells(Rows.Count, lngSpalte).End(xlUp)).Value2
    For a = UBound(avntValues, 1) To LBound(avntValues, 1) Step -1
        If avntValues(a, 1) <= 0 Then Rows(a).delete shift:=xlUp
    Next a
    
    lr = GetLastWrittenRowNr("Statistik") 'letzte beschriebene Zeile im Tabellenblatt Statistik
    tc = 1 'Zähler für die Zeilennummer in der die berechnete Medianzeit gespeichert wird
    
    Set rngBereich = Worksheets("Auswertung").Range("K:K")
    
    For rc = 2 To lr
        
        'zu durchsuchende Bereich
        
        'Kopieren der Durchführungszeiten die zu einer Testfall-ID gehören
        
        '========================NEU Anfang========================
        
        Set SearchTestcaseid = rngBereich.Find(Worksheets("Statistik").Cells(rc, 1).value)
        
        'wird geprüft, ob der Wert vorhanden ist
        If Not SearchTestcaseid Is Nothing Then
            
            
            FirtsSearchTestcaseid = SearchTestcaseid.Address 'Erste Suche wird gepeichert
            
            Do
                berzähler = berzähler + 1
                Worksheets("Berechnung").Cells(berzähler, 1).value = _
                    Worksheets("Auswertung").Cells(SearchTestcaseid.row, 17).value
                Set SearchTestcaseid = rngBereich.FindNext(SearchTestcaseid)
            Loop Until FirtsSearchTestcaseid = SearchTestcaseid.Address
            
            '========================NEU Ende========================
            
            ' For Each rngZelle In rngBereich
            ' If rngZelle.value = testcaseid Then
            ' rowcounter = rngZelle.row
            ' tctime = Worksheets("Auswertung").Cells(rowcounter, 17).value
            ' Worksheets("Berechnung").Cells(berzähler, 1).value = tctime
            'intZähler = intZähler + 1
            'berzähler = berzähler + 1
            ' End If
            ' Next
            
            'Medianzeit im Tabellenblatt Berechnung berechnen
            Worksheets("Statistik").Cells(rc, 3).value = _
                WorksheetFunction.Median(Worksheets("Berechnung").Columns(1))
            
            'Tabellenblatt berechnung leeren bevor nächste medianzeit berechnet wird
            Worksheets("Berechnung").Columns(1).Clear
            
        End If
    Next rc
    
    EnableAppFeedback
    
    MsgBox Format(Now - DatAnfang, "hh:mm:ss"), , "Makro-Laufzeit"
    
End Sub

Sub Testcasetimeclear()
    Range(Cells(2, 3), Cells(Rows.Count, 2)).ClearContents
End Sub

Gruß
Nepumuk
Anzeige
AW: Code Optimierung
18.01.2020 09:54:44
Nepumuk
Hallo kocius,
da ist noch ein Fehler drin. Teste mal damit:
Sub searchandsave()
    
    Dim DatAnfang As Date
    DatAnfang = Now
    
    Dim rngBereich As Range
    Dim berzähler As Long
    
    '############################################################################Schleife
    
    Dim lr As Long 'lastwrittenrow im Reiter "Statistik" 1 Spalte
    Dim rc As Long 'Zeilenzähler
    
    Dim lngSpalte As Long
    Dim a As Long
    Dim avntValues As Variant
    Dim FirtsSearchTestcaseid As String
    
    '========================NEU Anfang========================
    Dim SearchTestcaseid As Range
    '========================NEU Ende========================
    
    DisableAppFeedback
    
    '** Spalte, die auf Leerzeichen geprüft werden soll
    lngSpalte = 1
    avntValues = Range(Cells(1, lngSpalte), Cells(Rows.Count, lngSpalte).End(xlUp)).Value2
    For a = UBound(avntValues, 1) To LBound(avntValues, 1) Step -1
        If avntValues(a, 1) <= 0 Then Rows(a).delete shift:=xlUp
    Next a
    
    lr = GetLastWrittenRowNr("Statistik") 'letzte beschriebene Zeile im Tabellenblatt Statistik
    
    Set rngBereich = Worksheets("Auswertung").Range("K:K")
    
    With Worksheets("Berechnung")
        
        For rc = 2 To lr
            
            'Kopieren der Durchführungszeiten die zu einer Testfall-ID gehören
            
            '========================NEU Anfang========================
            
            Set SearchTestcaseid = rngBereich.Find(Worksheets("Statistik").Cells(rc, 1).Value)
            
            'wird geprüft, ob der Wert vorhanden ist
            If Not SearchTestcaseid Is Nothing Then
                
                
                FirtsSearchTestcaseid = SearchTestcaseid.Address 'Erste Suche wird gepeichert
                
                Do
                    berzähler = berzähler + 1
                    .Cells(berzähler, 1).Value = SearchTestcaseid.Offset(0, 6).Value
                    Set SearchTestcaseid = rngBereich.FindNext(SearchTestcaseid)
                Loop Until FirtsSearchTestcaseid = SearchTestcaseid.Address
                
                '========================NEU Ende========================
                
                'Medianzeit im Tabellenblatt Berechnung berechnen
                Worksheets("Statistik").Cells(rc, 3).Value = _
                    WorksheetFunction.Median(.Columns(1))
                
                'Tabellenblatt berechnung leeren bevor nächste medianzeit berechnet wird
                .Columns(1).Clear
                
            End If
        Next rc
    End With
    
    EnableAppFeedback
    
    MsgBox Format(Now - DatAnfang, "hh:mm:ss"), , "Makro-Laufzeit"
    
End Sub

Sub Testcasetimeclear()
    Range(Cells(2, 3), Cells(Rows.Count, 2)).ClearContents
End Sub

Gruß
Nepumuk
Anzeige
AW: Code Optimierung
18.01.2020 08:56:38
Luschi
Hallo kocius,
in dieser Arbeitsmappe läuft Einiges schief:
- die Werte in Auswertung!K2:K? sind keine echten Zahlen
- z.B.: Auswertung!K14 mit dem Inhalt '0061'
- diese Zelle ist aber als 'Standard' formatiert
- und deshalb mü0te dort '61' stehen
- bei einem Klick in die Zelle (oder F2-Taste) und Enter wird daraus auch '61'
- und so ist es bei den anderen Zellen auch
- die Funktion MEDIAN braucht aber echte Zahlen
- und nicht Werte, die zufällig wie Zahlen aussehen
zum Vba-Code
- Du ermittelst am Anfang die letzte Zelle in Statistik!A:A
- anschließend holst Du Auswertung!K:K nach Statistik!A:A
- auch danach sind die Werte in Statistik!A:A keine echten Zahlen
- denn sie sind es in Auswertung!K:K auch nicht
- es erfolgen weitere Veränderungen in Statistik:A:A
- aber die letzte belegte Zelle in Statistik!A:A wird nicht neu berechnet
- deshalb ist die bedingte Formatierunmg in dieser Spalte mehrfach vorhanden mit immer wieder neuen
  Wertebereichen
- man muß die alte bedinte Formatierung erst Löschen und dann eine neue setzten
- die Verwendung von 'IstZahl' sorgt dafür, daß die bedingte Formatierung klappt
- aber es ist so wie bei den JA-Sagern, im Hintergrund denken sie ganz anders
- und MEDIAN ist in diesem Fall der Hintergrund
Gruß von Luschi
aus klein-Paris
Anzeige
AW: Code Optimierung
18.01.2020 09:06:38
kocius
Danke Luschi für die Rückmeldung,
schaue mir später noch genauer an
Gruss
AW: Code Optimierung
18.01.2020 09:36:31
kocius
Danke Luschi für die Rückmeldung,
schaue mir später noch genauer an
Gruss
AW: Code Optimierung
18.01.2020 11:34:27
kocius
Danke Nepumuk für die Rückmeldung, schaue mir später
Gruss
AW: Code Optimierung
18.01.2020 11:48:20
Nepumuk
Hallo kocius,
jetzt ist mir gerade noch ein Fehler aufgefallen. Der Zeilenzähler wird nicht zurückgesetzt.
Sub searchandsave()
    
    Dim DatAnfang As Date
    DatAnfang = Now
    
    Dim rngBereich As Range
    Dim berzähler As Long
    
    '############################################################################Schleife
    
    Dim lr As Long 'lastwrittenrow im Reiter "Statistik" 1 Spalte
    Dim rc As Long 'Zeilenzähler
    
    Dim lngSpalte As Long
    Dim a As Long
    Dim avntValues As Variant
    Dim FirtsSearchTestcaseid As String
    
    '========================NEU Anfang========================
    Dim SearchTestcaseid As Range
    '========================NEU Ende========================
    
    DisableAppFeedback
    
    '** Spalte, die auf Leerzeichen geprüft werden soll
    lngSpalte = 1
    avntValues = Range(Cells(1, lngSpalte), Cells(Rows.Count, lngSpalte).End(xlUp)).Value2
    For a = UBound(avntValues, 1) To LBound(avntValues, 1) Step -1
        If avntValues(a, 1) <= 0 Then Rows(a).delete shift:=xlUp
    Next a
    
    lr = GetLastWrittenRowNr("Statistik") 'letzte beschriebene Zeile im Tabellenblatt Statistik
    
    Set rngBereich = Worksheets("Auswertung").Range("K:K")
    
    With Worksheets("Berechnung")
        
        For rc = 2 To lr
            
            'Kopieren der Durchführungszeiten die zu einer Testfall-ID gehören
            
            '========================NEU Anfang========================
            
            Set SearchTestcaseid = rngBereich.Find(Worksheets("Statistik").Cells(rc, 1).Value)
            
            'wird geprüft, ob der Wert vorhanden ist
            If Not SearchTestcaseid Is Nothing Then
                
                FirtsSearchTestcaseid = SearchTestcaseid.Address 'Erste Suche wird gepeichert
                
                berzähler = 0
                
                Do
                    berzähler = berzähler + 1
                    .Cells(berzähler, 1).Value = SearchTestcaseid.Offset(0, 6).Value
                    Set SearchTestcaseid = rngBereich.FindNext(SearchTestcaseid)
                Loop Until FirtsSearchTestcaseid = SearchTestcaseid.Address
                
                '========================NEU Ende========================
                
                'Medianzeit im Tabellenblatt Berechnung berechnen
                Worksheets("Statistik").Cells(rc, 3).Value = _
                    WorksheetFunction.Median(.Columns(1))
                
                'Tabellenblatt berechnung leeren bevor nächste medianzeit berechnet wird
                .Columns(1).Clear
                
            End If
        Next rc
    End With
    
    EnableAppFeedback
    
    MsgBox Format(Now - DatAnfang, "hh:mm:ss"), , "Makro-Laufzeit"
    
End Sub

jetzt bin ich mir sicher das ich alle Fehler ausgemerzt habe.
Gruß
Nepumuk
Anzeige
AW: Code Optimierung
18.01.2020 11:56:22
kocius
Danke Nepumuk vielmals für Deine Mühe, schaue mir später an
Gruss und ein schönes Wochenende!
AW: Code Optimierung
08.02.2020 23:16:57
kocius
Danke Nepumuk vielmals für Deine Mühe, schaue mir später an
Gruss und ein schönes Wochenende!

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige