Web sayfasından 900 sayfalık veriye çekmek

[tahsinanarat]

http://www.otoerdem.com/tamliste/renault/renaultliste.php?page=1&param1=valu1&param2=value2

yukarıdaki linkten saadece page= numaraları değişen yani 1 den 950 ye kadar sayfalardaki bilgileri excel sayfasında alt alta çekmek istiyorum. Bunu saadece tek bir sayfa için yapabiliyorum ancak bunu bir seferde yapabilmek için uzman arkadaşlarımdan yardım istiyorum.

 

[halit3]

http://www.otoerdem.com/tamliste/renault/renaultliste.php?page=1&param1=valu1&param2=value2

yukarıdaki linkten saadece page= numaraları değişen yani 1 den 950 ye kadar sayfalardaki bilgileri excel sayfasında alt alta çekmek istiyorum. Bunu saadece tek bir sayfa için yapabiliyorum ancak bunu bir seferde yapabilmek için uzman arkadaşlarımdan yardım istiyorum.

Bu uygulamanızda ben deneme amacıyla döngüyü beşinci sayfaya kadar yaptım siz kendinize göre döngüyü çoğaltın.

kod:

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 [COLOR=red]5
[/COLOR]  URL_LİNK = "[URL]http://www.otoerdem.com/tamliste/renault/renaultliste.php?page[/URL]=" & 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

 

[halit3]

Buda farklı bir uygulama siz sadece kırmızı yeri değiştirin.

kod :

Private Declare Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function apiShowWindow Lib "user32" Alias "ShowWindow" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Sub CommandButton1_Click()
Set IE = CreateObject("InternetExplorer.Application")
URL = "[URL]http://www.otoerdem.com/tamliste/renault/renaultliste.php?page=1&param1=valu1&param2=value2[/URL]"
If (InternetCheckConnection(URL & "/", &H1, 0&) = 0) Then MsgBox "internet bağlantısı yok": Exit Sub
Columns("A:E").ClearContents
sat = 1
Cells(sat, 1) = "Sayfa1"
sat = sat + 1
With IE
.Navigate URL
.Visible = 1
apiShowWindow IE.hwnd, 2
son_sayfa =[COLOR=red] 3[/COLOR]
For r = 1 To son_sayfa
.Navigate "[URL]http://www.otoerdem.com/tamliste/renault/renaultliste.php?page[/URL]=" & r & "&param1=valu1&param2=value2"
Do Until IE.ReadyState = 4: DoEvents: Loop
Do While IE.Busy: DoEvents: Loop
Do Until IE.ReadyState = 4: DoEvents: Loop
'Application.Wait (Now + TimeValue("00:00:02"))
On Error Resume Next
With .Document.getElementsByTagName("TABLE").Item(1)
For i = 0 To .Rows.Length + 1
For j = 0 To .Rows(0).Cells.Length + 1
Cells(sat, j + 1) = WorksheetFunction.Trim(.Rows(i).Cells(j).InnerText)
Next
sat = sat + 1
Next
If r <> son_sayfa Then
Cells(sat - 1, 1) = "Sayfa" & r + 1
End If
Cells(sat - 1, 1).Select
End With
Next
IE.Quit: Set IE = Nothing
End With
MsgBox ("Bitti  ")
End Sub

not: 900 sayfa veri almak baya uzun bir zaman almakta bana kalırsa küçük sayfalar halinde veri almanız uygun olur.

 

[Zeki Gürsoy]

*** Bilgi : Kod çalışırken windows pencere değişikliğinde bilinmeyen nedenle kırılıyor. ***

Navigasyon gerektirmeyen web ten veri alma işlemlerinde XMLHTTP hız açsısından çok uygun.

Listeniz 950 (toplamda 1.056 görünüyor) sayfa ile 95 bin küsür satır içeriyor. Excel versiyonunuzun eski olabileceğini düşünerekten iki dosya ile ekledim.

Kolay gelsin.

Option Explicit

Sub t_anarat()
Dim HTTP As Object, doc As Object, tbl As Object
Dim son_sayfa As Integer, i As Integer, j As Integer, sat As Long, m As Integer
Dim tempURL As String

Const URL As String = "http://www.otoerdem.com/tamliste/renault/renaultliste.php?page=[PAGE]&param1=valu1&param2=value2"

son_sayfa = 950
sat = 1



For m = 1 To son_sayfa
    [B]Set HTTP = CreateObject("MSXML2.XMLHTTP")[/B]
    Set doc = CreateObject("HTMLFile")
    
    DoEvents
    
    tempURL = Replace(URL, "[PAGE]", CStr(m))
    
    HTTP.Open "get", tempURL, False
    HTTP.send
    
    doc.write (StrConv(HTTP.responsebody, vbUnicode))
    
    Set tbl = doc.getElementsByTagName("table").Item(1)
    
    For i = 0 To tbl.Rows.Length - 1
        For j = 0 To tbl.Rows(i).Cells.Length - 1
            Cells(i + sat, j + 1) = tbl.Rows(i).Cells(j).innerText
        Next
        sat = sat + 1
    Next
    
    Set tbl = Nothing
    Set doc = Nothing
    Set HTTP = Nothing
    
    Application.StatusBar = "Sayfa " & m
Next

Application.StatusBar = False

MsgBox "İşlem bitti", vbInformation, "::.. www.excel.web.tr"
End Sub

 

[tahsinanarat]

Sn. Halit hocam ve Sn. Zeki hocam her ikinize de ayrı ayrı teşekkür ediyorum, elinize ve klavyenize sağlık. Hemen deneyeceğim.