Websitesinden Sınav sorularını Excele Çekme

[ahmetozcan9211]

http://www.sinavsorucevap.com/sorucozogg.aspx?s=1&a=1&x=658 sitesindeki soruları ve şıkları excele çekmek istiyorum.
excel şablonu aşağıdaki gibi olmasını istiyorum. yardımcı olur musunuz?
http://s8.dosya.tc/server5/4lhns7/Sinav.xlsx.html

 

[TanerSaydam]

İstediğiniz şeyi araştırarak şöyle bir bilgiye ulaştım. Excel sayfasındayken Veri>Dışarıdan Veri Al>Web'den seçeneğini tıklatın. Açılan pencereye veri almak istediğiniz siteyi yazıp, bağlanın. Sitede veriyi almak istediğiniz alanın yanında ? tarzı yere tıkladığınız da Onay işareti belirecek. Veriyi Aktar dediğinizde o kısmı Excel'deki istediğiniz yere alır. Ben şu anda istediğiniz tarzda şeyi makro ile yapabilir miyiz ona bakıyorum. Eğer yapabilirsem dosyanızı paylaşırım.

 

[Asri]

Bu şekilde deneyiniz.

Zaman zaman .readyState = 4 sorun oluyor ancak bir iki denemede sorular geliyor.

Dim islem, URL As String
Dim ie As Object
Dim objCollection As Object

Sub menu()
    Application.ScreenUpdating = False
    Range("A:Z").Clear
    Call url_ac
    Call getir
    ie.Quit
    Call parcala
    Application.ScreenUpdating = True
    MsgBox ("İşlem tamamlandı")
End Sub

Sub parcala()
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
    Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
    Range("B2").Select
    Columns("A:A").ColumnWidth = 67
    Cells.Select
    Cells.EntireRow.AutoFit
    Range("A2").Select
    Rows("1:1").RowHeight = 38.25
    Range("A2").Select
    
    sonsatir = Cells(Rows.Count, "A").End(3).Row
    For i = 1 To sonsatir
       veri = Cells(i, "B").Value
       veri = Replace(veri, Chr(13), "_")
       Cells(i, "B").Value = veri
       liste = Split(veri, "_")
       For j = LBound(liste) To UBound(liste)
            Cells(i, j + 3).Value = liste(j)
       Next j
    Next i
    Columns("B:B").Delete Shift:=xlToLeft
End Sub

Sub getir()
  Set objCollection = ie.document.getElementbyid("MainContent_UpdatePanel1").getElementsByTagName("td")
  i = 0
  satir = 2
  sutun = 1
  Do While i < objCollection.Length
    Cells(satir, sutun).Value = objCollection(i).innerText
    i = i + 1
    If i Mod 5 = 0 Then
       sutun = 0
       satir = satir + 1
    End If
    sutun = sutun + 1
  Loop
End Sub

Sub bekle()
    With ie
        Z = 0
        Do Until .readyState = 4: DoEvents:
          Z = Z + 1
          If Z > 10000 Then Exit Do
        Loop
        Do While .Busy: DoEvents: Loop
    End With
End Sub

Sub url_ac()
    URL = "http://www.sinavsorucevap.com/sorucozogg.aspx?s=1&a=1&x=658"
    Set ie = CreateObject("InternetExplorer.Application")
    With ie
      .Navigate URL
      .Visible = 1
    End With
    Call bekle
basla:
   If InStr(ie.document.body.innerText, "Soru No: 1") = 0 Then
      GoTo basla
   End If
   
End Sub