Hatırlatma programı foruma eklenmiştir.
http://www.excelce.net/forum/index.php?topic=1661.0

Gönderen Konu: Sözlük internet sitesi  (Okunma sayısı 3472 defa)

0 Üye ve 1 Ziyaretçi konuyu incelemekte.

Çevrimdışı Hikmetotheron

  • Excelce Onbaşı
  • **
  • İleti: 12
  • Puan +0/-0
  • Cinsiyet: Bay
  • Excel'den Daha Fazlası!..
  • Ad Soyad: Hikmet Kolukısa
  • Doğum Yılınız: 1971
  • İl / İlçe: Ankara/Yenimahalle
  • İşletim Sisteminiz: Windows Xp
  • Mesleğiniz: Memur
  • Office Versiyonunuz: Office Xp
Sözlük internet sitesi
« : 06 Mayıs 2020, 12:00:00 »
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.
:)

Çevrimdışı Hikmetotheron

  • Excelce Onbaşı
  • **
  • İleti: 12
  • Puan +0/-0
  • Cinsiyet: Bay
  • Excel'den Daha Fazlası!..
  • Ad Soyad: Hikmet Kolukısa
  • Doğum Yılınız: 1971
  • İl / İlçe: Ankara/Yenimahalle
  • İşletim Sisteminiz: Windows Xp
  • Mesleğiniz: Memur
  • Office Versiyonunuz: Office Xp
Ynt: Sözlük internet sitesi
« Yanıtla #1 : 07 Mayıs 2020, 00:54:46 »
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
:)