Exit a Macro

Sharid

Well-known Member
Joined
Apr 22, 2007
Messages
1,024
Office Version
  1. 2016
Platform
  1. Windows
I want to be able to exit a running macro. I have two buttons on a user form, which need to do the following

Button 1 Starts the macro
Button 2 End that macro.

Currently in Button1 I have this
VBA Code:
InActivePagesEnabled(MultiPage15) = False ' Disable all Multipage tabs apart from current
         Application.Run "Module9.SortData" ' Module9 is called, this has a large code in it and is the main code, this code LOOPS, I need to be able to stop this code when button2 is clicked
InActivePagesEnabled(MultiPage15) = True 'Enable all Multipage tabs

I need a code to enable me to stop Module9 from running, when Button2 is clicked. Most of the stuff I am finding online is around DO LOOPS, which I not what I am after. I want the Module to STOP and not just go into a loop process.

I have tried "End" how this caused the userform to also shut down, which is NOT what I am after. I am not sure how to link an "Exit Sub" to this Module so when Button2 is clicked it exits the sub, but the userform stays open.
 

Some videos you may like

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.

eduzs

Well-known Member
Joined
Jul 6, 2014
Messages
689
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
I suppose it's impossible to stop a macro clicking another button (control in a form or worksheet). Maybe should modify the code to exit the loop when some condition is achieved.
 

6StringJazzer

Well-known Member
Joined
Jan 27, 2010
Messages
714
Office Version
  1. 365
Platform
  1. Windows
We cannot give specifics without having the code for Module9.SortData. The overall strategy is:

  1. Declare a variable Public Disable As Boolean at the top of Module9
  2. In your click handler for Button 2 set Disable to False.
  3. Create a Click event handler for Button 2 that changes Disable to True
  4. In SortData you must insert code in many places that exits the sub if Disable is True.

    Also for any of this to work at all your UserForm has to be modeless. (UserForm.Show Modal:=False) or set the ShowModal property to False. Otherwise, you will not be able to click Button 2 while SortData is running. However, this could cause you other problems; I can't say without knowing your overall design.

I suppose it's impossible to stop a macro clicking another button
Some things are impossible but not this one. :)
 

eduzs

Well-known Member
Joined
Jul 6, 2014
Messages
689
Office Version
  1. 2019
  2. 2010
Platform
  1. Windows
Sorry! I thought that when a code is started by pressing a button it does not allow the click of another button until it has finished executing.
It's good to know:
Also for any of this to work at all your UserForm has to be modeless. (UserForm.Show Modal:=False) or set the ShowModal property to False. Otherwise, you will not be able to click Button 2 while SortData is running. However, this could cause you other problems; I can't say without knowing your overall design.
Thanks!
 

Sharid

Well-known Member
Joined
Apr 22, 2007
Messages
1,024
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

Here is the code, a bit long, but any help will do.

I was trying to add an if statement so, If the value from a sheet cell stated "Start" the code would run and if it stated "Stop" then it would stop. I could not get it to work

Also if anyone can help change the Mailto: to a regxp that would be super. I have been stuck on that one forever.

VBA Code:
Private Sub EmailExtractBut()
'Extract emails only from urls
'Columns for both tables
Const colUrl As Long = 1 'Must always be the first column
Const colMail As Long = 2 'Must always be the first column before SoMe platforms
Const colFacebook As Long = 3
Const colInstagram As Long = 4
Const colTwitter As Long = 5
Const colYouTube As Long = 6
Const colLinkedIn As Long = 7 'Must always be the last column of Some platforms
Const colError As Long = 9 'Must always be the last column


Dim url As String
Dim http As Object
Dim htmlDoc As Object
Dim nodeAllLinks As Object
Dim nodeOneLink As Object
Dim pageLoadSuccessful As Boolean
Dim tableUrlsOneAddressLeft As String
Dim tableAllAddresses As String
Dim currentRowTableUrls As Long
Dim lastRowTableUrls As Long
Dim currentRowsTableAll(colUrl To colLinkedIn) As Long
Dim lastRowTableAll As Long
Dim addressCounters(colMail To colLinkedIn) As Long
Dim checkCounters As Long
Dim myCounter As Long
  'Initialize variables
  tableUrlsOneAddressLeft = "Sheet9" 'change to sheet9
  currentRowTableUrls = 2 'First row for content
  tableAllAddresses = "Sheet8" 'chanhe to sheet8
DoEvents
  For checkCounters = colUrl To colLinkedIn
    currentRowsTableAll(checkCounters) = 2 'First rows for content
       
DoEvents
    Next checkCounters
  Set htmlDoc = CreateObject("htmlfile")
On Error Resume Next
  Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
 
  'Clear all contents and comments in the URL source sheet from email column to error column
DoEvents
  With Sheets(tableUrlsOneAddressLeft)
    lastRowTableUrls = .Cells(Rows.Count, colUrl).End(xlUp).Row
    .Range(.Cells(currentRowTableUrls, colMail), .Cells(lastRowTableUrls, colError)).ClearContents
    .Range(.Cells(currentRowTableUrls, colMail), .Cells(lastRowTableUrls, colError)).ClearComments
  End With
 
  'Delete all rows except headline in the sheet with all addresses
  lastRowTableAll = Sheets(tableAllAddresses).Cells(Rows.Count, colUrl).End(xlUp).Row
  Sheets(tableAllAddresses).Rows(currentRowsTableAll(colUrl) & ":" & lastRowTableAll).Delete Shift:=xlUp
 
'add new headings
ThisWorkbook.Worksheets("Sheet8").Range("A1").Value = "Domain Urls"
ThisWorkbook.Worksheets("Sheet8").Range("B1").Value = "Emails Found"
ThisWorkbook.Worksheets("Sheet8").Range("C1").Value = "Facebook Urls "
ThisWorkbook.Worksheets("Sheet8").Range("D1").Value = "Instagram Urls"
ThisWorkbook.Worksheets("Sheet8").Range("E1").Value = "Twitter Urls"
ThisWorkbook.Worksheets("Sheet8").Range("F1").Value = "Youtube Urls"
ThisWorkbook.Worksheets("Sheet8").Range("G1").Value = "LinkedIn Urls"
'ThisWorkbook.Worksheets("Sheet10").Range("j5").Value = "True"
 
Application.ScreenUpdating = False
  'Loop over all URLs in column A in the URL source sheet
'DoEvents
  Do While Sheets(tableUrlsOneAddressLeft).Cells(currentRowTableUrls, 1).Value <> ""
    'Scroll for visual monitoring, if
    'the sheet with the URLs are the
    'active one

    If ActiveSheet.Name = tableUrlsOneAddressLeft Then
      If currentRowTableUrls > 1 Then 'change this variable
        ActiveWindow.SmallScroll down:=1
      End If
      Sheets(tableUrlsOneAddressLeft).Cells(currentRowTableUrls, 1).Select
    End If
   
    'Get next url from the URL source sheet
    url = Sheets(tableUrlsOneAddressLeft).Cells(currentRowTableUrls, colUrl).Value
   
    'Try to load page
    'Temporarily disable error handling if
    'there is a timeout or onother error
On Error Resume Next
    http.Open "GET", url, False
On Error Resume Next
    http.send
   
    'Check if page loading was successful
DoEvents
    If Err.Number = 0 Then
      pageLoadSuccessful = True
    End If
    On Error GoTo 0
   
    If pageLoadSuccessful Then
      'Build html document for DOM operations
On Error Resume Next
      htmlDoc.body.innerHTML = http.responseText
      'Create node list from all links of the page
On Error Resume Next
      Set nodeAllLinks = htmlDoc.getElementsByTagName("a")
      'Walk through all links of the node list
           
      For Each nodeOneLink In nodeAllLinks
Application.ScreenUpdating = False

       
DoEvents
        If InStr(1, nodeOneLink.href, "mailto:") Then
          'Write mail address to both tables
          Sheets(tableUrlsOneAddressLeft).Cells(currentRowTableUrls, colMail).Value = Right(nodeOneLink.href, Len(nodeOneLink.href) - InStr(nodeOneLink.href, ":"))
          Sheets(tableAllAddresses).Cells(currentRowsTableAll(colMail), colMail).Value = Right(nodeOneLink.href, Len(nodeOneLink.href) - InStr(nodeOneLink.href, ":"))
          'Check if it is a new line in the sheet with all addresses

          If currentRowsTableAll(colMail) >= currentRowsTableAll(colUrl) Then
            'Write URL in the new line of the sheet with all addresses
            Sheets(tableAllAddresses).Cells(currentRowsTableAll(colUrl), colUrl).Value = url
            'Increment url counter
            currentRowsTableAll(colUrl) = currentRowsTableAll(colUrl) + 1
          End If

          'Increment mail counters
          currentRowsTableAll(colMail) = currentRowsTableAll(colMail) + 1
          addressCounters(colMail) = addressCounters(colMail) + 1
        End If

        'Check for Facebook address
        If InStr(1, UCase(nodeOneLink.href), "FACEBOOK") Then
          'Write Facebook address to both tables
  
          Sheets(tableUrlsOneAddressLeft).Cells(currentRowTableUrls, colFacebook).Value = nodeOneLink.href
          Sheets(tableAllAddresses).Cells(currentRowsTableAll(colFacebook), colFacebook).Value = nodeOneLink.href
          'Check if it is a new line in the sheet with all addresses
         
       If currentRowsTableAll(colFacebook) >= currentRowsTableAll(colUrl) Then
            'Write URL in the new line of the sheet with all addresses
    
            Sheets(tableAllAddresses).Cells(currentRowsTableAll(colUrl), colUrl).Value = url
            'Increment url counter
            currentRowsTableAll(colUrl) = currentRowsTableAll(colUrl) + 1
        End If

          'Increment Facebook counters
          currentRowsTableAll(colFacebook) = currentRowsTableAll(colFacebook) + 1
     
          addressCounters(colFacebook) = addressCounters(colFacebook) + 1
        End If

        'Check for Instagram address
        If InStr(1, UCase(nodeOneLink.href), "INSTAGRAM") Then
          'Write INSTAGRAM address to both tables
  
          Sheets(tableUrlsOneAddressLeft).Cells(currentRowTableUrls, colInstagram).Value = nodeOneLink.href
          Sheets(tableAllAddresses).Cells(currentRowsTableAll(colInstagram), colInstagram).Value = nodeOneLink.href
          'Check if it is a new line in the sheet with all addresses

        If currentRowsTableAll(colInstagram) >= currentRowsTableAll(colUrl) Then
            'Write URL in the new line of the sheet with all addresses
    
            Sheets(tableAllAddresses).Cells(currentRowsTableAll(colUrl), colUrl).Value = url
            'Increment url counter
            currentRowsTableAll(colUrl) = currentRowsTableAll(colUrl) + 1
        End If
         
          currentRowsTableAll(colInstagram) = currentRowsTableAll(colInstagram) + 1
          addressCounters(colInstagram) = addressCounters(colInstagram) + 1
        End If

        'Check for Twitter address
        If InStr(1, UCase(nodeOneLink.href), "TWITTER") Then
          'Write Twitter address to both tables
    
          Sheets(tableUrlsOneAddressLeft).Cells(currentRowTableUrls, colTwitter).Value = nodeOneLink.href
          Sheets(tableAllAddresses).Cells(currentRowsTableAll(colTwitter), colTwitter).Value = nodeOneLink.href
          'Check if it is a new line in the sheet with all addresses

       If currentRowsTableAll(colTwitter) >= currentRowsTableAll(colUrl) Then
            'Write URL in the new line of the sheet with all addresses
      
            Sheets(tableAllAddresses).Cells(currentRowsTableAll(colUrl), colUrl).Value = url
            'Increment url counter
            currentRowsTableAll(colUrl) = currentRowsTableAll(colUrl) + 1

          End If
          'Increment Twitter counters
          currentRowsTableAll(colTwitter) = currentRowsTableAll(colTwitter) + 1
          addressCounters(colTwitter) = addressCounters(colTwitter) + 1
        End If

        'Check for YouTube address
        If InStr(1, UCase(nodeOneLink.href), "YOUTUBE") Then
          'Write YouTube address to both tables
     
          Sheets(tableUrlsOneAddressLeft).Cells(currentRowTableUrls, colYouTube).Value = nodeOneLink.href
          Sheets(tableAllAddresses).Cells(currentRowsTableAll(colYouTube), colYouTube).Value = nodeOneLink.href
          'Check if it is a new line in the sheet with all addresses


          If currentRowsTableAll(colYouTube) >= currentRowsTableAll(colUrl) Then
            'Write URL in the new line of the sheet with all addresses
            Sheets(tableAllAddresses).Cells(currentRowsTableAll(colUrl), colUrl).Value = url
            'Increment url counter
            currentRowsTableAll(colUrl) = currentRowsTableAll(colUrl) + 1
           
          End If

          'Increment YouTube counters
          currentRowsTableAll(colYouTube) = currentRowsTableAll(colYouTube) + 1
          addressCounters(colYouTube) = addressCounters(colYouTube) + 1
        End If

        'Check for LinkedIn address
        If InStr(1, UCase(nodeOneLink.href), "LINKEDIN") Then
          'Write LinkedIn address to both tables
     
          Sheets(tableUrlsOneAddressLeft).Cells(currentRowTableUrls, colLinkedIn).Value = nodeOneLink.href
          Sheets(tableAllAddresses).Cells(currentRowsTableAll(colLinkedIn), colLinkedIn).Value = nodeOneLink.href
          'Check if it is a new line in the sheet with all addresses
          If currentRowsTableAll(colLinkedIn) >= currentRowsTableAll(colUrl) Then
            'Write URL in the new line of the sheet with all addresses
            Sheets(tableAllAddresses).Cells(currentRowsTableAll(colUrl), colUrl).Value = url
            'Increment url counter
            currentRowsTableAll(colUrl) = currentRowsTableAll(colUrl) + 1
          End If

          'Increment LinkedIn counters
          currentRowsTableAll(colLinkedIn) = currentRowsTableAll(colLinkedIn) + 1
          addressCounters(colLinkedIn) = addressCounters(colLinkedIn) + 1
        End If

      Next nodeOneLink

      'Check address counters
      For checkCounters = colMail To colLinkedIn
        'Set comment if more than 1 link were found
        If addressCounters(checkCounters) > 1 Then
          Sheets(tableUrlsOneAddressLeft).Cells(currentRowTableUrls, checkCounters).AddComment Text:=CStr(addressCounters(checkCounters))
          Sheets(tableUrlsOneAddressLeft).Cells(currentRowTableUrls, checkCounters).Comment.Shape.TextFrame.AutoSize = True
        End If

      Next checkCounters
    Else
      'Page not loaded
      'Write message URL table
      Sheets(tableUrlsOneAddressLeft).Cells(currentRowTableUrls, colError).Value = "Error with URL or timeout"
    End If
DoEvents
    'Prepare for next page
    pageLoadSuccessful = False
    Erase addressCounters
    lastRowTableAll = Sheets(tableAllAddresses).Cells(Rows.Count, colUrl).End(xlUp).Row
    For checkCounters = colUrl To colLinkedIn
    currentRowsTableAll(checkCounters) = lastRowTableAll + 1 'First rows for next page content

DoEvents
    Next checkCounters

    currentRowTableUrls = currentRowTableUrls + 1
       
   
'''Email + Social email tab controle source
With ExcelWebScraper.EmailSocialListBox1
Dim t As Double
     .ColumnCount = 7
     .ColumnWidths = "150;100;100;100;100;100;100"
     .RowSource = "'" & Sheet8.Name & "'!$A$1:$i$" & Sheet8.Cells(Sheet8.Rows.Count, 1).End(xlUp).Row
t = Timer
Do Until Timer > t + 0.17

Loop

End With
'''loop counter, results in sheet10
myCounter = myCounter + 1
Worksheets("Sheet10").Range("G6").Value = myCounter
   DoEvents
Application.ScreenUpdating = True

Loop
  'Clean up
  Set http = Nothing
  Set htmlDoc = Nothing
  Set nodeAllLinks = Nothing
  Set nodeOneLink = Nothing
 
  'Check if this works now
  Complete.Show
 
  Sheet10.Range("G6").Value = ""
 
'''delete duplicates in sheet8 column B
Dim Cl As Range, Rng As Range

   With CreateObject("scripting.dictionary")
      For Each Cl In Sheets("Sheet8").Range("B2", Sheets("Sheet8").Range("B" & Rows.Count).End(xlUp))
         If Cl <> "" Then
            If Not .Exists(Cl.Value) Then
               .Add Cl.Value, Nothing
            Else
               If Rng Is Nothing Then Set Rng = Cl Else Set Rng = Union(Rng, Cl)
            End If
         End If
      Next Cl
   End With
   If Not Rng Is Nothing Then Rng.EntireRow.Delete
  
''' remove blank rows from listbox view
LastRow = Sheet8.Cells(Sheet8.Rows.Count, "A").End(xlUp).Row
Sheet10.Range("G21").Value = LastRow - 1
'''Email + Social email tab controle source

With ExcelWebScraper.EmailSocialListBox1
     .ColumnCount = 7
     .ColumnWidths = "150;100;100;100;100;100;100"
     .RowSource = "'" & Sheet8.Name & "'!$A$1:$i$" & Sheet8.Cells(Sheet8.Rows.Count, 1).End(xlUp).Row

End With

End Sub
 

Sharid

Well-known Member
Joined
Apr 22, 2007
Messages
1,024
Office Version
  1. 2016
Platform
  1. Windows
Here is a regxp, if anyone could change the mailto: to regxp [a-zA-Z0-9_\-\.]+)@((\[[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.)|(([a-zA-Z0-9\-]+\.)+))([a-zA-Z]{2,4}|[0-9]{1,3})(\]?

Either one of the two problems would be a great help
 

Sharid

Well-known Member
Joined
Apr 22, 2007
Messages
1,024
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

I have worked out how to stop and start the macro. I placed this at the start and the end if at the end of the code
VBA Code:
If Sheet10.Range("f24").Value = "Start" Then

I then placed this just before the Next Check Counter Part of the code.
VBA Code:
DoEvents
If Sheet10.Range("f24").Value = "Stopped" Then
  Exit Sub
End If
    Next checkCounters
    currentRowTableUrls = currentRowTableUrls + 1

This stops and starts the code. I know its not the best, but it works.

If anyone can have a look at how to convert the Mailto: to a regexp that would be great help for me as I have been stuck on it for sometime. This is the regxp part of the code, have been trying for weeks to implement it to work but can not work it out.

VBA Code:
Dim outputCollection As Collection
    Set outputCollection = New Collection
   
    Dim regEx As Object
    Set regEx = CreateObject("VBScript.RegExp")
   
    With regEx
        .Pattern = "[a-zA-Z0-9_\-\.]+)@((\[[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.)|(([a-zA-Z0-9\-]+\.)+))([a-zA-Z]{2,4}|[0-9]{1,3})(\]?"
        .Global = True
        Dim emailMatches As Object
        Set emailMatches = .Execute(htmlDocument.body.innerHTML)
    End With
   
    Dim matchFound As Object
    For Each matchFound In emailMatches
        On Error Resume Next ' De-duplicate here.
        outputCollection.Add matchFound.Value, Key:=matchFound.Value
        On Error GoTo 0
    Next matchFound
   
    Set GetEmailAddressesFromHtml = outputCollection
End Function
 

6StringJazzer

Well-known Member
Joined
Jan 27, 2010
Messages
714
Office Version
  1. 365
Platform
  1. Windows
Also if anyone can help change the Mailto: to a regxp that would be super.
What do you mean by that? Mailto: is a hyperlink protocol, and regexp is pattern matching. What does one have to do with the other? Also you seem to show exactly how to use regexp, although you are only showing part of a function. Can you include the entire function?

What is it that you want to do, and what happens instead?
 

Sharid

Well-known Member
Joined
Apr 22, 2007
Messages
1,024
Office Version
  1. 2016
Platform
  1. Windows
I do not wish to use the the Mailto part of the code, as it extracts fewer results.

This Part
VBA Code:
DoEvents
        If InStr(1, nodeOneLink.href, "mailto:") Then
          'Write mail address to both tables
          Sheets(tableUrlsOneAddressLeft).Cells(currentRowTableUrls, colMail).Value = Right(nodeOneLink.href, Len(nodeOneLink.href) - InStr(nodeOneLink.href, ":"))
          Sheets(tableAllAddresses).Cells(currentRowsTableAll(colMail), colMail).Value = Right(nodeOneLink.href, Len(nodeOneLink.href) - InStr(nodeOneLink.href, ":"))
          'Check if it is a new line in the sheet with all addresses

          If currentRowsTableAll(colMail) >= currentRowsTableAll(colUrl) Then
            'Write URL in the new line of the sheet with all addresses
            Sheets(tableAllAddresses).Cells(currentRowsTableAll(colUrl), colUrl).Value = url
            'Increment url counter
            currentRowsTableAll(colUrl) = currentRowsTableAll(colUrl) + 1
          End If

          'Increment mail counters
          currentRowsTableAll(colMail) = currentRowsTableAll(colMail) + 1
          addressCounters(colMail) = addressCounters(colMail) + 1
        End If

With the regxp I can get more results. My problems is II have been struggling to replace the mailto: part of the code with a regxp expression. Hope that makes more sense.

I found the regxp function on the web, I can't remember from where now, that is all I have. Sorry
 

Watch MrExcel Video

Forum statistics

Threads
1,122,244
Messages
5,595,032
Members
413,962
Latest member
PedroGomez9

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top