Mulitple Searches Varrying Terms

nbob

Board Regular
Joined
Nov 9, 2011
Messages
51
I need to Search Google Results for Column A Data. For Each Individual Term I need to know what has returned a google result containing specific terms...Ie a search within a search. I have no problem getting the web results of google imported into excel sheets but I can not figure out how to loop the process and search the results of Google for my keywords.

Basically I have Column A Value that is added to the Google Search Url with "URL" & srchtrm (srchtrm being Range) These Results will then be copy and pasted into Worksheet 3 where I will need to search for key words (ie "facebook", "linkedin", "Phone", "Myspace", etc.). If these keywords are found on individual Values in Column A then I would like to highlight the Value in A or assign it a score based on the number of terms that where found during the search in worksheet 3. I dont need to keep any of the google data once it has been searched I would prefer to delete the google data between loops. Any Ideas???:confused:

Here is the code I have so far:
Dim IE As Object
Dim srchtrm As String
srchtrm = Range("A2").Value
Dim FirstAddress As String
Dim MyArr As Variant
Dim Rng As Range
Dim Rcount As Long
Dim I As Long
Dim NewSh As Worksheet
Sheets("Sheet3").Select
Range("A1:A1000") = "" ' erase
Range("A1").Select

Set IE = CreateObject("InternetExplorer.Application")
With IE
.Visible = True
.Navigate "http://www.google.com.au/search?hl=en&q=" & srchtrm ' should work for any URL
While IE.Busy
DoEvents
Wend

IE.ExecWB 17, 0 '// SelectAll
IE.ExecWB 12, 2 '// Copy selection
ActiveSheet.PasteSpecial Format:="Text", link:=False, DisplayAsIcon:=False
Range("A1").Select

With Application
.ScreenUpdating = False
.EnableEvents = False
End With
MyArr = Array("facebook", "Linkedin", "Corporationwiki", "Myspace", "Phone")
Set NewSh = Worksheets.Add

With Sheets("sheet3").Range("A2:B999")

Rcount = 0
For I = LBound(MyArr) To UBound(MyArr)
Set Rng = .Find(What:=MyArr(I), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rcount = Rcount + 1
Rng.Copy NewSh.Range("A" & Rcount)
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With
With Application
.ScreenUpdating = True
.EnableEvents = True

End With
End With

End Sub
 

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.
I wasn't entirely sure what you were looking for, but here is my best guess:
Code:
Sub WordCount()

    Dim IE As Object
    Dim srchtrm As String
    Dim FirstAddress As String
    Dim MyArr As Variant
    Dim Rng As Range
    Dim Rcount As Long
    Dim I As Long
    Dim NewSh As Worksheet
    Dim lLastResultRow As Long
    Dim lFirstSearchTermRow As Long
    Dim lLastSearchTermRow As Long
    Dim lX As Long
    
    'All terms to be searched are in Sheet1, column A starting in row 2
    'Number of times any work in  of marched terms in MyArr show in results will be placed in column B
    
    lFirstSearchTermRow = 2
    lLastSearchTermRow = Worksheets("Sheet1").Cells(Worksheets("Sheet1").Rows.Count, 1).End(xlUp).Row
    
    MyArr = Array("facebook", "Linkedin", "Corporationwiki", "Myspace", "Phone")

    Set IE = CreateObject("InternetExplorer.Application")
    
    For lX = lFirstSearchTermRow To lLastSearchTermRow
        srchtrm = Worksheets("Sheet1").Cells(lX, 1).Value
        Application.StatusBar = "Processing: " & srchtrm
        Sheets("Sheet3").Select
        Sheets("Sheet3").UsedRange.Cells.Clear ' erase
        Range("A1").Select
        
        With IE
            .Visible = True
            .Navigate "http://www.google.com.au/search?hl=en&q=" & srchtrm ' should work for any URL
            While IE.Busy
                DoEvents
            Wend
            
            IE.ExecWB 17, 0 '// SelectAll
            IE.ExecWB 12, 2 '// Copy selection
            ActiveSheet.PasteSpecial Format:="Text", link:=False, DisplayAsIcon:=False
            Range("A1").Select
            
            lLastResultRow = Cells(Rows.Count, 1).End(xlUp).Row
            
            With Application
                .ScreenUpdating = False
                .EnableEvents = False
            End With
            
            Set NewSh = Worksheets.Add
            NewSh.Name = srchtrm
            
            If lLastResultRow > 1 Then
                With Sheets("sheet3").Range("A2:A" & lLastResultRow)
                
                    Rcount = 0
                    
                    For I = LBound(MyArr) To UBound(MyArr)
                        Set Rng = .Find(What:=MyArr(I), _
                            After:=.Cells(.Cells.Count), _
                            LookIn:=xlFormulas, _
                            LookAt:=xlPart, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
                        If Not Rng Is Nothing Then
                            FirstAddress = Rng.Address
                            Do
                                Rcount = Rcount + 1
                                Rng.Copy NewSh.Range("A" & Rcount)
                                Rng.Offset(0, 1).Value = Rng.Offset(0, 1).Value + 1
                                Set Rng = .FindNext(Rng)
                            Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
                        End If
                    Next I
                End With
            Else
                Rcount = 0
            End If
            
        End With
        Worksheets("Sheet1").Cells(lX, 2).Value = Rcount
        
        Application.DisplayAlerts = False
        Worksheets(srchtrm).Delete
        Application.DisplayAlerts = True
    Next
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .StatusBar = False
    End With
End Sub
 
Upvote 0
WOW. I will definitely try this when i get home. Looks and sound right. Very pretty looking.
 
Upvote 0
Works fine only thing is that the webpage must need more time to load to allow the copy feature to work. I am getting results of 0 and notice the google page is not showing results before moving on to the next srchtrm...Doesnt the Wend while page loading suppose to take care of that? Would I need to perhaps give it an actual amount of time to load say .3 secs? THoughts. Your brilliant by the way.
 
Upvote 0
I believe the
While IE.Busy Wend block
should allow time for the page to load. I got non-zero results for some of my keywords. facebook returned 48, I believe.
Put a stop command at the bottom of the main loop and comment out the worksheet deletion line so you can see what is retrieved and what is picked out.
 
Upvote 0
I switched the url to search.yahoo works great. I think the auto complete on Google was slowing down the results and the program was copy pasting the blank pages. ??
 
Upvote 0
Well it works great with a few terms but I put in more than 20 and it seems to get held up with runtime 1004 error at this:

Code:
ActiveSheet.PasteSpecial Format:="Text", link:=False, DisplayAsIcon:=False

any suggestions?
 
Upvote 0
Here is the only issue now that I have switched the URL I can run 300 terms easily but it seems that I am copy/pasting the same IE browser search to three sometime four terms in a row. I can watch the program run and the IE browser will be open to the same search page but excel will have went through and scored four terms of the same IE search page. I have no idea where to add a when busy command to fix this I have tried it in multiple areas but to no avail. any thoughts?
 
Upvote 0

Forum statistics

Threads
1,203,059
Messages
6,053,294
Members
444,650
Latest member
bookendinSA

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