Get from Table + Search in Google + Enter to a new column

Hi, Not a lot of information to go on, however you can try this.

This script will take any name in col "I" Google it. and will return the link to the page in col "J"

I have also attached a workbook for ease of use. If you are going to use in another workbook you will need to set some Ref in vba editior before it will work. such as:

Microsoft Internet Controls

A test workbook is below. It takes several seconds for the data to populate and I have only about 6 names entered. So I imagine that 10000 names will take a bit of time.

I would suggest you copy your names to this test book and try to run the script.

Let me know how it works out.

Sub RNG5000()
Dim cel As Object, cell As Object
Dim r As Range, r2 As Range
Dim lrow As Long, NewLrow As Long
Dim MyStr As String, MyStr2 As String
Dim count, i As Integer, x As String
Dim ie As InternetExplorer
Dim NewSht As Worksheet, OldSht As Worksheet
Dim IEDoc As Object
Application.ScreenUpdating = False
Set ie = CreateObject("InternetExplorer.application")
lrow = Range("I65536").End(xlUp).Row
Set r = Range("I2:I" & lrow)
For Each cell In r
MyStr = cell.Value
With ie
.Visible = False
.Navigate ("http://www.google.com/")
While .Busy Or .ReadyState <> 4
DoEvents
Wend
    .Document.all.q.Value = MyStr
    .Document.all.btnG.Click
End With
Application.Wait (Now + TimeValue("0:00:02"))
Set OldSht = ActiveSheet
Set NewSht = Sheets.Add
Set IEDoc = ie.Document
    For i = 0 To IEDoc.Links.Length - 1
        'write the linking url to a cell
       'cell.Offset(, 1).Value = IeDoc.Links(i).href
     NewSht.Cells(i + 1, 1).Value = IEDoc.Links(i).href
 
    Next i
 
    NewLrow = NewSht.Range("A65536").End(xlUp).Row
    Set r2 = NewSht.Range("A1:A" & NewLrow)
    For Each cel In r2
 
    MyStr = LCase(MyStr)
    MyStr = Replace(MyStr, " ", "")
    MyStr2 = "http://www." & MyStr & ".com/"
    NewSht.Cells.Find MyStr2
 
 
    If cel.Value Like MyStr2 Then
        cell.Offset(, 1).Value = cel.Value 'IeDoc.Links(i).href
        Exit For
    End If
 
    Next cel
 
    Application.DisplayAlerts = False
    NewSht.Delete
    Application.DisplayAlerts = True
    OldSht.Columns("I:J").AutoFit
 
Next cell
HyperLink
ie.Quit
Set ie = Nothing
Application.ScreenUpdating = True
End Sub
Sub HyperLink()
Dim r As Range
Dim myvalue As String
Dim lastrow As Long
lastrow = Range("J65536").End(xlUp).Row
   For Each r In Range("J2:J" & lastrow)
 
      If InStr(r, "http://") > 0 Or InStr(r, "www.") > 0 Then
         myvalue = r.Value
            Range(r.Address).Select
               ActiveSheet.Hyperlinks.Add Anchor:=Selection, _
                                                  Address:=myvalue, _
                                                  TextToDisplay:=myvalue
      End If
   Next r
    Range("J1").Select
End Sub

,
...,,

Originally Posted by tahiryildiz

Hello,

It works but can not find a website of the companies. I don't know why but I entered about 20 entries and it could only find 3 of them.

Is it normal?

You could try to run a couple of times. I did notice that when I put the script together that at times it did skip some names.

Can you list a few of the names it left blank. I Like to run some tests on your data. This scrpt only looks for ".com" maybe I could work on it when I get some time.

.

These are some of my entries:

ÇAĞDAŞ TIP GEREÇLERİ SAN VE TİC.LTD
İNTERDEKOR İLYAS ADUT
ÖNALANLAR YAPI MALZEMELERİ A.Ş.
ÖZDEMİR MAKİNE DIŞ TİC.MURAT ÖZDEMİ
ADORE OYUNCAK VE EĞT.ARÇ.SAN.TİC.A.



It commands to search but nothing happens, no entries...

Maybe my proxy doesn't let Excel to do this,but I don't guess so.

There should be a problem about something...

After Edit:

MY second try was this:

Fotokritik http://www.fotokritik.com/
Sigorta
Turkiye http://www.turkiye.com/
England
DAF http://www.daf.com/

Hi
Its Nice program......

Ya Sure..But am new to this..

Markandan26,

You will get all the help you need. But for that, you need to create a new thread as per what Kyle explained.