New macros needed

kleinermuk

New Member
Joined
Nov 3, 2020
Messages
30
Office Version
  1. 2010
Platform
  1. Windows
I have a list of companies, so I am wondering a macros can be created where a name of each company is taken one by one and opened in a new Google search page/tab?
 
I just run it again, still the same pop up message appears and no URL is recorded.

Just to verify, here is how the macros looking now after your editing:

Sub Find_URLs_in_Google()
'Control Page Down / Page Up

Dim co_name As String
lra = Range("a" & Rows.Count).End(3).Row

For company_count = 2 To lra
co_name = Sheets(1).Range("A" & company_count).Value

Sheets.Add after:=Sheets(Sheets.Count) 'this should create a new worksheet for new querry
querry_add co_name


'####################################
Application.Wait (Now + #12:00:01 AM#) 'this will make the macro stop for a second after each querry. You can also delete the empty and ### lines, just cannot make it more obvious :D
'####################################


Sheets(1).Range("b" & company_count).Value = Sheets(Sheets.Count).Range("A21").Value
Sheets(1).Range("C" & company_count).Value = Sheets(Sheets.Count).Range("A22").Value
Sheets(Sheets.Count).Delete 'this should delete the last worksheet

Next company_count
End Sub
Sub querry_add(co_name As String)
search_link = "URL;Veterans Day 2020""" & co_name & """"
'bounch of the below with part is not necessary, but i let it there
With ActiveSheet.QueryTables.Add(Connection:=search_link, Destination:=Range("$A$1"))
.Name = "search?q=""magnotta winery""#spf=1604993071782"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
End Sub
 
Upvote 0

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
I tried to run the last macros until the end, eventhough I needed to click Cancel on every screen, which I did not mind.

However, it's stopped after about 50 records. The error message 1 is attached.

Then it would not even allow me to restart macros, with Error Message 2 is attached.
 

Attachments

  • Error1.jpg
    Error1.jpg
    117.4 KB · Views: 4
  • Error2.jpg
    Error2.jpg
    102.1 KB · Views: 4
Upvote 0
can you send me the list
I tested with my 60 is random site worked w/o any problem :\
 
Last edited by a moderator:
Upvote 0
I ran the below macro on your file. Looks like google wants some proof we are not robots :D thats why not providing result after some time.
Also made some modification like: macro try to find the first cell starting with "www" (for me its 25, 26, but often goes over 50th row). I put that to different sub. Turned of screenupdating.
(also fixed the link to this thread -.-' shame on me :D )
VBA Code:
Sub Find_URLs_in_Google()
'https://www.mrexcel.com/board/threads/new-macros-needed.1150242

Dim co_name As String
lra = Range("a" & Rows.Count).End(3).Row
For company_count = 2 To lra
co_name = Sheets(1).Range("A" & company_count).Value
Sheets.Add after:=Sheets(Sheets.Count)
On Error Resume Next
querry_add co_name
On Error GoTo -1
find_www_in_a company_count
Sheets(Sheets.Count).Delete
Application.Wait (Now + #12:00:01 AM#)
Next company_count

End Sub
Private Sub querry_add(co_name As String)
search_link = "URL;https://www.google.com/search?q=""" & co_name & """"
'bounch of the below with part is not necessary, but i let it there
    With ActiveSheet.QueryTables.Add(Connection:=search_link, Destination:=Range("$A$1"))
        .Name = "search?q=""magnotta winery""#spf=1604993071782"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
End Sub
Private Sub find_www_in_a(company_count)

For Each cell In Range("A20:A70")
If Left(Trim(cell.Value), 3) = "www" Then www_row = cell.Row: GoTo exit_cell_loop
Next cell
Exit Sub

exit_cell_loop:
Sheets(1).Range("b" & company_count).Value = Sheets(Sheets.Count).Range("A" & www_row).Value
Sheets(1).Range("C" & company_count).Value = Sheets(Sheets.Count).Range("A" & www_row + 1).Value

End Sub
 
Upvote 0
still no luck as it stopped pulling data after about 45th line.
 

Attachments

  • Doc5.jpg
    Doc5.jpg
    111.2 KB · Views: 4
Upvote 0
Hmm, first of all, the non-deleted-sheets also worry me. Probably the google has that 40-50 quick search limit. I talked about this project with some of fellow 'inmates', they had to verify themself on google sites, not just me :) THey asked me, why this happend... :)
I suggest make 30-30-30-ish list, if thats works with the shortened list wait 5-10 min then run on the next list.
But... still... that sheets shouldn't be there :( :\
 
Upvote 0
it seems like 40 records per file would be a good number. Is there a macros which can divide my original file into multiple files consisting of 40 records each?
 
Upvote 0
Hi, start this on the sheet where the original list is
VBA Code:
Sub cut_to_40_per_sheet()
Set sht_active = ActiveSheet
lra = sht_active.Range("A" & Rows.Count).End(3).Row
i = 0
Do
Sheets.Add , after:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Range("A1:A40").Value = sht_active.Range("A1:A40").Offset(i, 0).Value
    i = i + 40
Loop Until i > lra
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,532
Messages
6,114,177
Members
448,554
Latest member
Gleisner2

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
Back
Top