Kann man mein Makro beschleunigen?

Forumthread: Kann man mein Makro beschleunigen?

18.10.2024 17:04:39

Christian

Hallo,

mal eine Frage an euch VBA Experten,
nachfolgendes Makro braucht dank der großen Bereiche ewig und 3 Tage bis es fertig ist. Auch wenn sich die Bereiche nicht verkleinern lassen, hat jemand von euch vielleicht noch eine andere Idee wie man das beschleunigen kann?

Vielen Dank
Christian



Sub Makro1()

    Dim ws As Worksheet

    Dim rng As Range

    Dim data As Variant

    Dim i As Long

    Dim cellValue As String

    Dim ws17 As Worksheet, ws18 As Worksheet, ws19 As Worksheet

    Dim rng17 As Range, rng18 As Range, rng19 As Range

    Dim foundInSpecialRange As Boolean



    ' Bildschirmaktualisierung und Berechnung deaktivieren

    Application.ScreenUpdating = False

    Application.Calculation = xlCalculationManual



    ' Setze das Arbeitsblatt "alle" und den relevanten Bereich, der bearbeitet wird

    Set ws = ThisWorkbook.Worksheets("alle")

    Set rng = ws.Range("A1:A423757") ' Bereich, der bearbeitet wird

    

    ' Setze die Arbeitsblätter und relevanten Bereiche für die Überprüfung

    Set ws17 = ThisWorkbook.Worksheets("17")

    Set ws18 = ThisWorkbook.Worksheets("18")

    Set ws19 = ThisWorkbook.Worksheets("19")



    Set rng17 = ws17.Range("B551648:B994429")

    Set rng18 = ws18.Range("B1:B987640")

    Set rng19 = ws19.Range("B1:B750786")



    ' Lade den Bereich in ein Array

    data = rng.Value2



    ' Durchlaufe jede Zelle im Array

    For i = 1 To UBound(data, 1)

        cellValue = data(i, 1)



        ' Prüfe, ob der Zellwert ein String ist und ob er mit ".html" endet

        If InStr(cellValue, "about:") > 0 And Right(cellValue, 5) = ".html" Then

            foundInSpecialRange = False



            ' Überprüfe, ob der Wert in einem der speziellen Bereiche auf den Blättern '17', '18' oder '19' vorhanden ist

            If Not IsError(Application.Match(cellValue, rng17, 0)) Then

                foundInSpecialRange = True

            ElseIf Not IsError(Application.Match(cellValue, rng18, 0)) Then

                foundInSpecialRange = True

            ElseIf Not IsError(Application.Match(cellValue, rng19, 0)) Then

                foundInSpecialRange = True

            End If



            ' Ersetze "about:" basierend auf der Überprüfung

            If foundInSpecialRange Then

                ' Wenn der Wert in einem der speziellen Bereiche gefunden wurde

                data(i, 1) = Replace(cellValue, "about:", "Text1")

            Else

                ' Wenn der Wert nicht in den speziellen Bereichen gefunden wurde

                data(i, 1) = Replace(cellValue, "about:", "Text2")

            End If

        ElseIf InStr(cellValue, "about:") > 0 And Right(cellValue, 4) = ".jpg" Then

            ' Ersetze "about:" durch "https:" in .jpg-Links

            data(i, 1) = Replace(cellValue, "about:", "https:")

        End If

    Next i



    ' Übertrage das geänderte Array zurück in den Bereich

    rng.Value2 = data



    ' Bildschirmaktualisierung und Berechnung wieder aktivieren

    Application.ScreenUpdating = True

    Application.Calculation = xlCalculationAutomatic

End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Kann man mein Makro beschleunigen?

18.10.2024 18:11:39

Yal

Hallo Christian,

ja, es gibt Potential...

z.B. Du prüfst zweimal InStr(cellValue, "about:") > 0
Ein Kleinigkeit, die sich summiert.

Die Löwenanteil steckt aber in dem Vergleich (Application.Match). Bei der Menge lohnt es sich über eine Dictionary zu gehen. Hier werden die Einträge vorgekaut gesammelt, sodass schon ein Grossenteil der Durchsuch-Aufgabe erledigt ist und zwar nur einmal (wenn Du Details möchtest, google nach hash table).

Sub Makro1()

Dim Dic As Object

Dim rng As Range

Dim data As Variant

Dim i As Long



' Bildschirmaktualisierung und Berechnung deaktivieren

    Application.ScreenUpdating = False

    Application.Calculation = xlCalculationManual



'Bildung eines Dictionary

    Set Dic = CreateObject("scripting.dictionary")

    For Each rng In Union(Worksheets("17").Range("B551648:B994429"), Worksheets("18").Range("B1:B987640"), Worksheets("19").Range("B1:B750786"))

        Dic(rng.Value) = 1

    Next

    

' Lade den Bereich in ein Array

    Set rng = Worksheets("alle").Range("A1:A423757")  ' Bereich, der bearbeitet wird

    data = rng.Value2

    

' Durchlaufe jede Zelle im Array

    For i = 1 To UBound(data, 1)

        If InStr(data(i, 1), "about:") > 0 Then

            If Right(data(i, 1), 5) = ".html" Then

                data(i, 1) = Replace(data(i, 1), "about:", IIf(Dic.Exists(data(i, 1)), "Text1", "Text2")) 'Verwendung der Dictionary

            ElseIf Right(data(i, 1), 4) = ".jpg" Then

                data(i, 1) = Replace(data(i, 1), "about:", "https:") ' Ersetze "about:" durch "https:" in .jpg-Links

            End If

        End If

    Next i



' Übertrage das geänderte Array zurück in den Bereich

    rng.Value2 = data



' Bildschirmaktualisierung und Berechnung wieder aktivieren

    Application.ScreenUpdating = True

    Application.Calculation = xlCalculationAutomatic

End If

VG
Yal

AW: Kann man mein Makro beschleunigen?

18.10.2024 18:34:38

snb

Sub M_snb()

   sn = Sheets("alle").Range("A1:A423757")

    

   sp = [transpose(17!B551648:B994429]

   sq = [transpose(18!B1:B987640]

   sr = [transpose(19!B1:B750786]

    

    sp = Filter(Filter(Split(Join(sp, Chr(0)) & Chr(0) & Join(sq, Chr(0)) & chr(0) & Join(sr, Chr(0)), Chr(0)), "about"), ".html")

    

    For j = 0 To UBound(sn)

      If UBound(Filter(sp, sn(j, 1))) > -1 Then sn(j, 1) = Replace(sn(j, 1), "about", "found")

    Next

End Sub

AW: Kann man mein Makro beschleunigen?

18.10.2024 19:21:28

ralf_b

Ich hab auch was gebastelt, das zwar wahrscheinlich nicht an die beiden andern herankommt, aber mich würde mal interessieren was die zeitliche Komponente hier ergibt. Natürlich nur wenn der Code läuft.

Sub Makro1()

    Dim cnt&, endtxt$, arrws, arrbereich, found As Boolean

    Dim arrdata, data, i&

    

    ' Bildschirmaktualisierung und Berechnung deaktivieren

    Application.ScreenUpdating = False

    Application.Calculation = xlCalculationManual



    ' Setze das Arbeitsblatt "alle" und den relevanten Bereich, der bearbeitet wird

     arrdata = ThisWorkbook.Worksheets("alle").Range("A1:A423757")

    ' Setze die Arbeitsblätter und relevanten Bereiche für die Überprüfung

 

    arrws = Split("17,18,19", ",")

    arrbereich = Split("B551648:B994429,B1:B987640,B1:B750786", ",")

   

   For i = 1 To UBound(arrdata)

       If Left(arrdata(i, 1), 6) = "about:" Then

            endtxt = Right(arrdata(i, 1), 5)

            Select Case endtxt

                Case "html"

                    For cnt = LBound(arrws) To UBound(arrws)

                       If Not IsError(Application.Match(arrdata(i, 1), ThisWorkbook.Worksheets(arrws(cnt)).Range(arrbereich(cnt)), 0)) Then

                            found = True

                            Exit For

                       End If

                    Next

                                         

                    arrdata(i, 1) = IIf(found, "Text1", "Text2") & Right(arrdata(i, 1), Len(arrdata(i, 1)) - 6)

                    found = False

                    

                 Case ".jpg": arrdata(i, 1) = "https:" & Right(arrdata(i, 1), Len(arrdata(i, 1)) - 6)

              End Select

        End If

   Next

   

   ThisWorkbook.Worksheets("alle").Range("A1:A423757").Value2 = arrdata ' Übertrage das geänderte Array zurück in den Bereich

   

    ' Bildschirmaktualisierung und Berechnung wieder aktivieren

    Application.ScreenUpdating = True

    Application.Calculation = xlCalculationAutomatic

End Sub

AW: Kann man mein Makro beschleunigen?

19.10.2024 02:25:42

daniel

Ja, kann man beschleunigen

Sortiere die Zellbereiche rng17, rng18,rng19 aufsteigend.

Ersetze das

If Not IsError(Application.Match(cellValue, rng17, 0)) Then

                foundInSpecialRange = True

Durch

If cellValue = Application.Vlookup(cellValue, rng17, 1, 1) then

         foundInSpecialRange = True

Und für die anderen Zellbereiche ebenso.

Aufgrund der Sortierung kann die wesentlich schnellere Variante des VLookups verwendet werden (4. Parameter = wahr/1) um Vorhandenseinsprüfung durchzuführen.

Gruß Daniel

AW: Kann man mein Makro beschleunigen?

18.10.2024 18:44:23

Christian

Hallo snb,

wow da noch durchzublicken ist für einen Laien wie mich fast schon unmöglich.
Nichts desto trotz, ich habe wie ich vorhin schon angemerkt hatte, festgestellt, dass jeder Text in alle mit about: beginnt, die Prüfung darauf also überflüssig ist.
Habe auch bei deinem Makro versucht, diese Prüfung zu entfernen, aber habe keine Ahnung mehr, ob ich da alles richtig gemacht habe, schaust du bitte mal?

Sub M_snb()

   sn = Sheets("alle").Range("A1:A423757")

    

   sp = [transpose(17!B551648:B994429]

   sq = [transpose(18!B1:B987640]

   sr = [transpose(19!B1:B750786]

    

    sp = Filter(Split(Join(sp, Chr(0)) & Chr(0) & Join(sq, Chr(0)) & chr(0) & Join(sr, Chr(0)), Chr(0)), ".html")

    

    For j = 0 To UBound(sn)

      If UBound(Filter(sp, sn(j, 1))) > -1 Then sn(j, 1) = Replace(sn(j, 1), "about", "found")

    Next

End Sub

AW: Kann man mein Makro beschleunigen?

18.10.2024 18:30:39

Christian

Hallo Yal,

ich habe in der Zwischenzeit noch etwas anderes überprüft und festgestellt dass jeder Text mit about: anfängt, diese Prüfung also wegfallen kann.

Hoffe ich hab deinen Vorschlag dahin gehend richtig abgeändert,

Sub Makro1()

Dim Dic As Object

Dim rng As Range

Dim data As Variant

Dim i As Long



' Bildschirmaktualisierung und Berechnung deaktivieren

    Application.ScreenUpdating = False

    Application.Calculation = xlCalculationManual



' Bildung eines Dictionary

    Set Dic = CreateObject("scripting.dictionary")

    For Each rng In Union(Worksheets("17").Range("B551648:B994429"), Worksheets("18").Range("B1:B987640"), Worksheets("19").Range("B1:B750786"))

        Dic(rng.Value) = 1

    Next



' Lade den Bereich in ein Array

    Set rng = Worksheets("alle").Range("A1:A423757")  ' Bereich, der bearbeitet wird

    data = rng.Value2



' Durchlaufe jede Zelle im Array

    For i = 1 To UBound(data, 1)

        If Right(data(i, 1), 5) = ".html" Then

            data(i, 1) = Replace(data(i, 1), "about:", IIf(Dic.Exists(data(i, 1)), "Text1", "Text2")) ' Verwendung der Dictionary

        ElseIf Right(data(i, 1), 4) = ".jpg" Then

            data(i, 1) = Replace(data(i, 1), "about:", "https:") ' Ersetze "about:" durch "https:" in .jpg-Links

        End If

    Next i



' Übertrage das geänderte Array zurück in den Bereich

    rng.Value2 = data



' Bildschirmaktualisierung und Berechnung wieder aktivieren

    Application.ScreenUpdating = True

    Application.Calculation = xlCalculationAutomatic

End Sub

Ich mache mich dann mal ans Testen,

danke schonmal für die Hilfe
Christian

AW: Kann man mein Makro beschleunigen?

19.10.2024 06:06:54

Eifeljoi 5

Hallo
Vielleicht etwa so?? Ungetestet

Sub Makro1()

    Dim ws As Worksheet, rng As Range, data As Variant

    Dim i As Long, cellValue As String, dict As Object, wsSpecial As Worksheet, cell As Range



    Application.ScreenUpdating = False

    Application.Calculation = xlCalculationManual



    Set ws = ThisWorkbook.Worksheets("alle")

    Set rng = ws.Range("A1:A423757")

    data = rng.Value2



    Set dict = CreateObject("Scripting.Dictionary")

    dict.CompareMode = TextCompare



    For Each wsSpecial In ThisWorkbook.Worksheets(Array("17", "18", "19"))

        For Each cell In wsSpecial.UsedRange

            dict(cell.Value) = 1

        Next cell

    Next wsSpecial



    For i = 1 To UBound(data, 1)

        cellValue = data(i, 1)

        If InStr(cellValue, "about:") > 0 Then

            If Right(cellValue, 5) = ".html" Then

                data(i, 1) = Replace(cellValue, "about:", IIf(dict.exists(cellValue), "Text1", "Text2"))

            ElseIf Right(cellValue, 4) = ".jpg" Then

                data(i, 1) = Replace(cellValue, "about:", "https:")

            End If

        End If

    Next i



    rng.Value2 = data



    Application.ScreenUpdating = True

    Application.Calculation = xlCalculationAutomatic

End Sub

Beliebteste Forumthreads (12 Monate)

Kann man mein Makro beschleunigen?

Forumthread: Kann man mein Makro beschleunigen?

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread