3 Allgemeine Fragen zu makros

Christian · 2024-07-25T07:51:13+00:00

Hallo, Ich bitte euch darum, 3 Fragen zu meinem makro zu beantworten, allgemeine Fragen, die man auch zu jedem anderen makro stellen könnte. Also, ich habe ein makro, welches 10x dasselbe makro aufruft, jedesmal mit einem anderen tabellenblatt als Parameter. Zur Zeit wird es mit den ersten 4 blättern ausgeführt, die anderen 6 sind auskommentiert. Nun zu meinen fragen: 1. Kann ich das makro pausieren und später an der selben Stelle fortsetzen und wenn ja wie 2. Kann ich die Pause nutzen um das auskommentieren der 6 Blätter aufzuheben? Und trotzdem an derselben Stelle fortsetzen 3. Kann ich in der Pause an anderen blättern der Tabelle weiterarbeiten, welche nicht vom makro betroffen sind? Und weiterhin dann an der selben Stelle fortsetzen Danke für eure Mühe Christian

Also habe jetzt folgendes gemacht:

Das ursprüngliche Makro



Public Sub Makro2(sh As String)

    Dim objIE As Object

    Dim objLinks As Object

    Dim objLink As Object

    Dim lngCount As Long

    Dim lloRow As Long

    Dim lshTab2 As Worksheet

    

    Set lshTab2 = Sheets(sh)

    Set objIE = CreateObject("InternetExplorer.Application")

    

    With objIE

        .Visible = False

        

        For lloRow = 1 To lshTab2.Cells(lshTab2.Rows.Count, 1).End(xlUp).Row

            .Navigate lshTab2.Range("A" & lloRow).Text

            

            Do While .Busy Or .readyState > 4

                DoEvents

            Loop

            

            ' Check if the page loaded successfully

            If .LocationURL > "about:blank" Then

                Set objLinks = .document.Links

                

                For Each objLink In objLinks

                    lngCount = lngCount + 1

                    lshTab2.Cells(lngCount, 2) = objLink.href

                    lshTab2.Cells(lngCount, 3) = "'" & objLink.outerText

                Next objLink

            End If

            

            Application.Wait (Now + TimeValue("0:00:05"))

        Next lloRow

        

        .Quit

    End With

    

    Set objIE = Nothing

    Set lshTab2 = Nothing

End Sub

erstmal habe ich gesagt, dass die Sachen in Spalte C und D eingetragen werden sollen, damit Spalte B für die X frei wird.

Public Sub Makro2(sh As String)

    Dim objIE As Object

    Dim objLinks As Object

    Dim objLink As Object

    Dim lngCount As Long

    Dim lloRow As Long

    Dim lshTab2 As Worksheet

    

    Set lshTab2 = Sheets(sh)

    Set objIE = CreateObject("InternetExplorer.Application")

    

    With objIE

        .Visible = False

        

        For lloRow = 1 To lshTab2.Cells(lshTab2.Rows.Count, 1).End(xlUp).Row

            .Navigate lshTab2.Range("A" & lloRow).Text

            

            Do While .Busy Or .readyState > 4

                DoEvents

            Loop

            

            ' Check if the page loaded successfully

            If .LocationURL > "about:blank" Then

                Set objLinks = .document.Links

                

                For Each objLink In objLinks

                    lngCount = lngCount + 1

                    lshTab2.Cells(lngCount, 3) = objLink.href

                    lshTab2.Cells(lngCount, 4) = "'" & objLink.outerText

                Next objLink

            End If

            

            Application.Wait (Now + TimeValue("0:00:05"))

        Next lloRow

        

        .Quit

    End With

    

    Set objIE = Nothing

    Set lshTab2 = Nothing

End Sub

dann habe ich gesagt, dass in jede abgearbeitete Zeile ein X geschrieben werden soll

Public Sub Makro2(sh As String)

    Dim objIE As Object

    Dim objLinks As Object

    Dim objLink As Object

    Dim lngCount As Long

    Dim lloRow As Long

    Dim lshTab2 As Worksheet

    

    Set lshTab2 = Sheets(sh)

    Set objIE = CreateObject("InternetExplorer.Application")

    

    With objIE

        .Visible = False

        

        For lloRow = 1 To lshTab2.Cells(lshTab2.Rows.Count, 1).End(xlUp).Row

            .Navigate lshTab2.Range("A" & lloRow).Text

            

            Do While .Busy Or .readyState > 4

                DoEvents

            Loop

            

            ' Check if the page loaded successfully

            If .LocationURL > "about:blank" Then

                Set objLinks = .document.Links

                

                For Each objLink In objLinks

                    lngCount = lngCount + 1

                    lshTab2.Cells(lngCount, 3) = objLink.href 

                    lshTab2.Cells(lngCount, 4) = "'" & objLink.outerText

                Next objLink

            End If

            

            lshTab2.Cells(lloRow, 2) = "X"

            

            Application.Wait (Now + TimeValue("0:00:05"))

        Next lloRow

        

        .Quit

    End With

    

    Set objIE = Nothing

    Set lshTab2 = Nothing

End Sub

und im 3. Schritt nur Links abarbeiten, neben denen kein X steht

Public Sub Makro2(sh As String)

    Dim objIE As Object

    Dim objLinks As Object

    Dim objLink As Object

    Dim lngCount As Long

    Dim lloRow As Long

    Dim lshTab2 As Worksheet

    

    Set lshTab2 = Sheets(sh)

    Set objIE = CreateObject("InternetExplorer.Application")

    

    With objIE

        .Visible = False

        

        For lloRow = 1 To lshTab2.Cells(lshTab2.Rows.Count, 1).End(xlUp).Row

            ' Prüfen, ob in Spalte B bereits ein "X" steht

            If lshTab2.Cells(lloRow, 2).Text > "X" Then

                .Navigate lshTab2.Range("A" & lloRow).Text

                

                Do While .Busy Or .readyState > 4

                    DoEvents

                Loop

                

                ' Check if the page loaded successfully

                If .LocationURL > "about:blank" Then

                    Set objLinks = .document.Links

                    

                    For Each objLink In objLinks

                        lngCount = lngCount + 1

                        lshTab2.Cells(lngCount, 3) = objLink.href 

                        lshTab2.Cells(lngCount, 4) = "'" & objLink.outerText

                    Next objLink

                End If

                

                lshTab2.Cells(lloRow, 2) = "X"

                

                Application.Wait (Now + TimeValue("0:00:05"))

            End If

        Next lloRow

        

        .Quit

    End With

    

    Set objIE = Nothing

    Set lshTab2 = Nothing

End Sub

dann noch die Prüfung, ob alle Einträge in einer Tabelle bereits ein X haben

Public Sub Makro2(sh As String)

    Dim objIE As Object

    Dim objLinks As Object

    Dim objLink As Object

    Dim lngCount As Long

    Dim lloRow As Long

    Dim lshTab2 As Worksheet

    Dim allX As Boolean

    

    Set lshTab2 = Sheets(sh)

    Set objIE = CreateObject("InternetExplorer.Application")

    

    With objIE

        .Visible = False

        

        ' Überprüfen, ob alle Zellen in Spalte B ein "X" enthalten

        allX = True

        For lloRow = 1 To lshTab2.Cells(lshTab2.Rows.Count, 1).End(xlUp).Row

            If lshTab2.Cells(lloRow, 2).Text > "X" Then

                allX = False

                Exit For

            End If

        Next lloRow

        

        ' Wenn nicht alle Zellen in Spalte B ein "X" enthalten, das Makro ausführen

        If Not allX Then

            For lloRow = 1 To lshTab2.Cells(lshTab2.Rows.Count, 1).End(xlUp).Row

                ' Prüfen, ob in Spalte B bereits ein "X" steht

                If lshTab2.Cells(lloRow, 2).Text > "X" Then

                    .Navigate lshTab2.Range("A" & lloRow).Text

                    

                    Do While .Busy Or .readyState > 4

                        DoEvents

                    Loop

                    

                    ' Check if the page loaded successfully

                    If .LocationURL > "about:blank" Then

                        Set objLinks = .document.Links

                        

                        For Each objLink In objLinks

                            lngCount = lngCount + 1

                            lshTab2.Cells(lngCount, 3) = objLink.href   ' Link in Spalte C

                            lshTab2.Cells(lngCount, 4) = "'" & objLink.outerText   ' Linktext in Spalte D

                        Next objLink

                    End If

                    

                    ' Schreib "X" in Spalte B neben den abgearbeiteten Link

                    lshTab2.Cells(lloRow, 2) = "X"

                    

                    Application.Wait (Now + TimeValue("0:00:05"))

                End If

            Next lloRow

        End If

        

        .Quit

    End With

    

    Set objIE = Nothing

    Set lshTab2 = Nothing

End Sub

das Hauptmakro



Public Sub Start()



Call Makro2("Tabelle1")

Call Makro2("Tabelle2")

Call Makro2("Tabelle3")

Call Makro2("Tabelle4")

Call Makro2("Tabelle5")

Call Makro2("Tabelle6")

Call Makro2("Tabelle7")

Call Makro2("Tabelle8")

Call Makro2("Tabelle9")

Call Makro2("Tabelle10")

End Sub

habe ich unverändert gelassen.

Was meint ihr dazu? bislang noch ungetestet

du hast mich jetzt auf eine andere Idee gebracht. Ich habe mein erstelltes Makro getestet, wie es sich verhält, wenn ich es abbreche und du hattest recht, es fehlen Daten.

Ich habe jetzt auch mal dahin gehend eine Lösung für mein vorhin erstelltes Makro gesucht und bin dabei auf GetAsyncKeyState gestoßen, was wohl nach jedem Schleifendurchlauf prüfen kann, ob währenddessen der Key mit dem Code schlag mich tot bei Escape 27 gedrückt wurde.

Habe jetzt lange gebraucht das einzubauen, da kam und kam ein Fehler, den ich nicht wegbekam und ich keine Ahnung hatte, wo er hekommt (Im Endeffekt lag es daran, dass wenn man einen Parameter an ein Makro übergibt, die Variable auch den selben Typ haben muss, der auch vom Makro erwartet wird.

Habe in dem Zug dann noch ErrorHandler eingebaut um zu schauen was los ist und die ganzen Tabellenblätter in ein Array gepackt, das Ganze sieht dann jetzt so aus und funktioniert:

' Globale Variable zur Steuerung des Abbruchs

Public abortRequested As Boolean



' API-Deklaration für die Überprüfung der Escape-Taste

Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer



Public Sub CheckForAbort()

    Dim key As Integer

    key = 27 ' Escape-Taste hat den Code 27

    If GetAsyncKeyState(key) > 0 Then

        abortRequested = True

    End If

End Sub



Public Sub Start()

    On Error GoTo ErrorHandler

    Dim wsNames As Variant

    wsNames = Array("Tabelle1", "Tabelle2", "Tabelle3", "Tabelle4", "Tabelle5", "Tabelle6", "Tabelle7", "Tabelle8", "Tabelle9", "Tabelle10")

    

    Dim i As Integer

    For i = LBound(wsNames) To UBound(wsNames)

        Makro2 wsNames(i) ' Parameterübergabe ohne Call

    Next i

    

    Exit Sub

    

ErrorHandler:

    MsgBox "An error occurred: " & Err.Description

    Resume Next

End Sub



Public Sub Makro2(sh As Variant)

    On Error GoTo ErrorHandler

    Dim objIE As Object

    Dim objLinks As Object

    Dim objLink As Object

    Dim lngCount As Long

    Dim lloRow As Long

    Dim lshTab2 As Worksheet

    Dim allX As Boolean

    Dim checkInterval As Integer

    Dim iterationCount As Integer

    

    Set lshTab2 = Sheets(sh)

    Set objIE = CreateObject("InternetExplorer.Application")

    

    ' Finde die erste freie Zeile in Spalte C

    lngCount = lshTab2.Cells(lshTab2.Rows.Count, 3).End(xlUp).Row + 1

    

    With objIE

        .Visible = False

        

        ' Überprüfen, ob alle Zellen in Spalte B ein "X" enthalten

        allX = True

        For lloRow = 1 To lshTab2.Cells(lshTab2.Rows.Count, 1).End(xlUp).Row

            If lshTab2.Cells(lloRow, 2).Text > "X" Then

                allX = False

                Exit For

            End If

        Next lloRow

        

        ' Wenn nicht alle Zellen in Spalte B ein "X" enthalten, das Makro ausführen

        If Not allX Then

            checkInterval = 1 ' Überprüfen alle 10 Iterationen

            iterationCount = 0

            

            For lloRow = 1 To lshTab2.Cells(lshTab2.Rows.Count, 1).End(xlUp).Row

                ' Prüfen, ob in Spalte B bereits ein "X" steht

                If lshTab2.Cells(lloRow, 2).Text > "X" Then

                    .Navigate lshTab2.Range("A" & lloRow).Text

                    

                    Do While .Busy Or .readyState > 4

                        DoEvents

                        iterationCount = iterationCount + 1

                        

                        ' Überprüfung der Escape-Taste nur alle checkInterval Iterationen

                        If iterationCount >= checkInterval Then

                            CheckForAbort

                            If abortRequested Then

                                ' Setze das "X" in Spalte B, auch wenn das Makro abgebrochen wird

                                'lshTab2.Cells(lloRow, 2).Value = "X"

                                Exit For

                            End If

                            iterationCount = 0

                        End If

                    Loop

                    

                    ' Wenn die Escape-Taste gedrückt wurde, beenden wir die Schleife

                    If abortRequested Then

                        Exit For

                    End If

                    

                    ' Check if the page loaded successfully

                    If .LocationURL > "about:blank" Then

                        Set objLinks = .document.Links

                        

                        For Each objLink In objLinks

                            lshTab2.Cells(lngCount, 3).Value = objLink.href   ' Link in Spalte C

                            lshTab2.Cells(lngCount, 4).Value = "'" & objLink.outerText   ' Linktext in Spalte D

                            lngCount = lngCount + 1

                        Next objLink

                    End If

                    

                    ' Schreib "X" in Spalte B neben den abgearbeiteten Link

                    lshTab2.Cells(lloRow, 2).Value = "X"

                    

                    Application.Wait (Now + TimeValue("0:00:05"))

                End If

            Next lloRow

        End If

        

        .Quit

    End With

    

    Set objIE = Nothing

    Set lshTab2 = Nothing

    abortRequested = False ' Reset the abort flag after completion



    Exit Sub

    

ErrorHandler:

    MsgBox "An error occurred: " & Err.Description

    abortRequested = False

    Resume Next

End Sub

Jetzt kümmere ich mich weiter um dein Makro, das sind aber im Moment noch ziemliche böhmische Dörfer, wie ich den Part des eigentlichen Makros ersetzen soll, damit das immer noch mit dem Rest des Makros funktioniert.

Forumthread: 3 Allgemeine Fragen zu makros

47
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

3 Allgemeine Fragen zu makros

Forumthread: 3 Allgemeine Fragen zu makros

47 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

47
Beiträge zum Forumthread

Beiträge zu diesem Forumthread