Web adresindeki linkden sayfaları çekmek

[tahsinanarat]

http://www.excel.web.tr/f48/web-sayfasyndan-900-sayfalyk-veriye-cekmek-t121692.html

Yukarıdaki linkde Sn. Halit Beyin kodları

http://www.excel.web.tr/f48/web-sayfasyndan-900-sayfalyk-veriye-cekmek-t121692.html

ile 1 dan 950 e kadar olan sayfaları tek seferde çekebiliyorduk.

Option Explicit

Sub VERİ_AL()
    Dim SAYFA As Worksheet, X As Long, URL_LİNK As String
 Dim sat
    Application.ScreenUpdating = False
 
    For Each SAYFA In Worksheets
        If SAYFA.Name <> "Sayfa1" Then
        Application.DisplayAlerts = False
        SAYFA.Delete
        Application.DisplayAlerts = True
        End If
    Next





    For X = 1 To 5
  URL_LİNK = "http://www.otoerdem.com/tamliste/ren...liste.php?page=" & X & "&param1=valu1&param2=value2"
    
    sat = Sheets("Sayfa1").Range("A65536").End(3).Row + 1

    'URL_LİNK = Sheets("Sayfa1").Cells(X, 1)
 
    ActiveWorkbook.Worksheets.Add , After:=Sheets(Worksheets.Count)
 
    ActiveSheet.Name = "ANALİZ_" & X
 
    With ActiveSheet.QueryTables.Add(Connection:="URL;" & URL_LİNK, Destination:=Range("A" & sat))      'Set S2 = Sheets("KURLAR") Destination:=S2.[A1])
        .Name = "ANALİZ_" & X
        .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

    Next

    Sheets("Sayfa1").Select

    Application.ScreenUpdating = True
    'MsgBox "İşleminiz tamamlanmıştır.", vbInformation
Range("A1").Select
End Sub

Bu kodlarda Formumuza ait Makro_VBA da açılan konu başlıkları olan

http://www.excel.web.tr/archive/index.php/f-48-p-10.html

adresindeki 1 den 192 e kadar olan sayfaları excele çekip bir arama motoru oluşturacağım, başarılı olursa diğer konuları da aynı şekilde yaparız.
Not: sayfalar excele manuel kopyala yapıştır yaptığımızda linkleri ile birlikte geliyor, kodlarla çektiğimiz de de aynı şekilde olması gerekli.

Yukarıda verdiğim linkde Sn. Zeki Beyin kodları da mevcut ancak denemede başarılı olamadım.
İlgilenecek arkadaşlarıma şimdiden teşekkür ederim.

 

[askm]

Aşağıdaki şekilde deneyin.

Sub ASKM_excel_web_tr()
    Dim ie As Object, i%, a%
    Dim Yazi As String
    Dim sat
    Set ie = CreateObject("internetexplorer.application")
    With ie
    Cells.ClearContents
    Sheets("Sayfa2").Range("A1").Value = " KONULAR "
    For i = 1 To 192
    adres = "http://www.excel.web.tr/archive/index.php/f-48-p-" & i & ".html"
    .navigate adres
    .Visible = True
    On Error GoTo Hata
    Do Until .readyState = 4: DoEvents: Loop
    Do While .Busy: DoEvents: Loop
    For y = 0 To 249
    sat = Sheets("Sayfa2").Range("A65536").End(3).Row + 1
       Yazi = .document.getElementById("content").getElementsByTagName("a")(y).innerText
       Sheets("Sayfa2").Range("A" & sat).Value = StrConv(Yazi, vbProperCase)
      
       ActiveSheet.Hyperlinks.Add Anchor:=Sheets("Sayfa2").Range("A" & sat), Address:= _
        adres, TextToDisplay:=StrConv(Yazi, vbProperCase)
    Next y
    Next i
Hata:
    .Quit
    End With
    Set ie = Nothing: i = Empty: a = Empty
    MsgBox "İşlem tamamlandı...", vbInformation, "ASKM"
End Sub

 

[tahsinanarat]

Slm askm Bey, öncelikle verdiğiniz cevap için çok teşekkür ederim, kodları şimdi denedim, güzel çalışıyor ancak 26. sayfada işlem tamamlandı diyor.(6287 satır) Yani 192 sayfaya kadar devem etmedi. iki kez denedim. Bakabilirseniz 47166 satır ben manüel olarak çekmiştim.

 

[tahsinanarat]

Sn.askm Bey
On Error GoTo Hata
ile ilgili satırları kaldırıp
On Error Resume Next yaptım, şu an 106. sayfaya kadar geldi, ama arada sayfa atlarmı bilmiyorum. Bitirsin bakayım.

 

[tahsinanarat]

Sn. askm Bey, indirme işlemi tamamlandı, ancak satıra tıkladığımda indirdiğimiz sayfa linkine gidiyor, ben istiyorum ki aynen manüel olarak yapıştırıp satıra tıkladığımda ilgili konunun bulunduğu sayfaya gittiği gibi olsun, bu şekilde olabilirse çok güzel olacak. Teşekkürler.

 

[askm]

on error hata kısmını örneğin siz döngüyü 250 yaparsınız 192 sayfa var 193. sayfayık bulamayacağı için hata verirse diye düşünmüştüm.
Aşağıdaki gibi deneyin.

Sub ASKM_excel_web_tr()
    Dim ie As Object, i%, a%
    Dim Yazi As String
    Dim sat
    Dim link
    Set ie = CreateObject("internetexplorer.application")
    With ie
    Cells.ClearContents
    Sheets("Sayfa2").Range("A1").Value = " KONULAR "
    For i = 1 To 192
    adres = "http://www.excel.web.tr/archive/index.php/f-48-p-" & i & ".html"
    .navigate adres
    .Visible = True
    On Error Resume Next
    Do Until .readyState = 4: DoEvents: Loop
    Do While .Busy: DoEvents: Loop
    For y = 0 To 249
    sat = Sheets("Sayfa2").Range("A65536").End(3).Row + 1
       
       link = .document.getElementById("content").getElementsByTagName("a")(y).href
       Yazi = .document.getElementById("content").getElementsByTagName("a")(y).innerText
       Sheets("Sayfa2").Range("A" & sat).Value = StrConv(Yazi, vbProperCase)
      
       ActiveSheet.Hyperlinks.Add Anchor:=Sheets("Sayfa2").Range("A" & sat), Address:= _
       link, TextToDisplay:=StrConv(Yazi, vbProperCase)
    Next y
    Next i
Hata:
    .Quit
    End With
    Set ie = Nothing: i = Empty: a = Empty
    MsgBox "İşlem tamamlandı...", vbInformation, "ASKM"
End Sub

 

[tahsinanarat]

Sn. askm kardeşim eline koluna sağlık tam istediğim gibi oldu, çok teşekkür ederim.

 

[askm]

Kolay gelsin.