Sözlük internet sitesi

[Hikmetotheron]

Merhaba. Öncelikle, böyle bir hizmeti sunduğunuzdan ötürü sizlere teşekkür ederim.

Bir Excel dosyasında çalıştırılacak makro program sayesinde  çıkacak pop up ekrana İngilizce kelimeler yazıldıktan sonra bu kelimeler A sütununa aralarında bir satır boşluk olacak şekilde yazılsın (Yani ilk kelime A1 hücresine, ikinci kelime A3 hücresine, üçüncü kelime A5 hücresine v.s. yazılsın.) ve daha sonra bu kelimelerin manaları https://www.lexico.com internet sitesinden alınıp karşılarındaki B sütununa yazılsın (Yani ilk kelimenin manası B1 hücresine, ikinci kelimenin manası B3 hücresine, üçüncü kelimenin B5 hücresine v.s. yazılsın.)

İyi günler.

[Hikmetotheron]

Merhaba.
Bu talebime benzer bir talebi aşağıdaki makro programıyla gerçekleştırmiştim. Aşağıdaki makro programını modifiye edilerek talebimi gerçekleştirmenizi sizlerden rica ediyorum.

Sub test()
Dim ie As Object
Set s1 = ThisWorkbook.Worksheets("Sheet 1")
Set ie = CreateObject("internetexplorer.application")
s1.AutoFilterMode = False
s1.Range("B:C").Clear
ie.Visible = True
ie.navigate "lexico.com"
Do: DoEvents: Loop Until Not ie.readystate <> 4
Bekle 1500


On Error Resume Next

For i = 1 To s1.Range("A65536").End(xlUp).Row

    ie.document.getElementById("q").Value = s1.Cells(i, 1)
    ie.document.getElementById("searchBtn").Click
    Do: DoEvents: Loop Until Not ie.readystate <> 4
    Bekle 3500

    tx = ie.document.body.innertext
    s = InStr(1, tx, "Pronunciation: /", vbTextCompare)
    If s = 0 Then
        s1.Cells(i, 2) = "-"
        s1.Cells(i, 3) = "Pronunciation: / bulunamadı"
        If InStr(1, tx, "No exact results found for ", vbTextCompare) > 0 Then
            s1.Cells(i, 3) = "No exact results found"
        End If
       
    Else
        tx = Mid(tx, s + Len("Pronunciation: /"), 100)
        s = InStr(1, tx, "/", vbTextCompare)
        tx = Mid(tx, 1, s - 1)
        s1.Cells(i, 2) = tx
    End If
    Set ie.document = Nothing

Next i
Set ie = Nothing
s1.Columns.AutoFit
End Sub

Private Function Bekle(ByVal MiliSaniye As Integer)
Dim t1 As Double
Dim t2 As Double
t1 = Timer + MiliSaniye / 1000
Do
DoEvents
t2 = Timer
Loop Until t2 > t1
End Function