Tablo sırasına göre veri indirme ve farklı kaydederek döngünün devam etmesi.

[aliturkmen]

Merhaba,
Sayın Halit beyin hazırlamış olduğu İş Yatırım sitesinden bilanço indirme çalışmasını, data sayfasında a1 hücresinden başlayarak indirmiş olduğu veriyi bulunduğu klasöre hücrede ki isim ile farklı kaydetmesi ve bir sonraki hücre ile devam etmesini sağlayacak bir döngü konusunda yardımlarınızı bekliyorum.
Örnek dosya ektedir.
İlginiz için şimdiden teşekkürler,
Not: Sayfa2 de açılır liste ile seçildiğinde veri alınmaktadır, amacımız datada ki listeye göre işlemi otomatik olarak devam etmesidir.

 

[ÖmerFaruk]

Kodları aşağıdaki gibi döngü içinde deneyebilirsin
Kodların aslına dokunmadım. Döngüye soktum ve dosyanın kopyasını kaydettim
Yine de denedim 6-7 satır için sorunsuz çalıştı.

Private Sub CommandButton1_Click()
Dim URL As String
Dim IE As Object
    Range("A2:E1500").ClearContents
    'ilave edilen for döngüsü.. ÖmerFaruk
    For i = 1 To Sheets("data").Range("A" & Rows.Count).End(3).Row
        ekle2 = Sheets("data").Cells(i, 1).Value 'Döngü için uyarlandı ÖmerFaruk
        URL = "https://www.isyatirim.com.tr/tr-tr/analiz/hisse/Sayfalar/sirket-karti.aspx?hisse=" & ekle2
        Set IE = CreateObject("InternetExplorer.Application")
        IE.Navigate URL
        IE.Visible = 1
        IE.Width = 200
        IE.Height = 100
        IE.Left = 10
        IE.Top = 0
        Do Until IE.ReadyState = 4: DoEvents: Loop
        Do While IE.Busy: DoEvents: Loop
        say1 = 2
        On Error Resume Next
        For Each tb In IE.document.getElementsByTagName("div")
            For Each bb In tb.getElementsByTagName("ul")
                For Each tr In bb.getElementsByTagName("li")
                    For Each ts In tr.getElementsByTagName("a")
                        If ts.ID = "page-4" Then
                            Application.Wait (Now + TimeValue("0:00:01"))
                            ts.Click
                            Do Until IE.ReadyState = 4: DoEvents: Loop
                            Do While IE.Busy: DoEvents: Loop
                            Application.Wait (Now + TimeValue("0:00:01"))
                            GoTo atla1
                        End If
                    Next ts
                Next tr
            Next bb
        Next tb
atla1:
        ekle = 0
        For Each tb In IE.document.getElementsByTagName("div")
            For Each bb In tb.getElementsByTagName("Table")
                For Each tr In bb.getElementsByTagName("tbody")
                    For Each ts In tr.getElementsByTagName("tr")
                        If "Bilanço" = ts.innerText Then ekle = 1
                        If "Dipnot" = ts.innerText Then GoTo atla2
                        If ekle = 1 Then
                        say1 = say1 + 1
                        sut = 1
                            For Each td In ts.getElementsByTagName("td")
                                If IsNumeric(td.innerText) = True Then
                                    Cells(say1, sut) = td.innerText * 1
                                    If Cells(say1, sut) = 0 Then Cells(say1, sut) = ""
                                Else
                                    Cells(say1, sut) = td.innerText
                                End If
                                sut = sut + 1
                            Next td
                        End If
                    Next ts
                Next tr
            Next bb
        Next tb
        
atla2:
        Application.Wait (Now + TimeValue("0:00:01"))
        IE = Nothing
        ' ilave edilen satır ÖmerFaruk
        ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & ekle2 & " - " & Format(Now, "dd.mm.yyyy") & ".xlsx"
    Next i
    IE.Quit: 'Set IE = Nothing
    MsgBox ("Bitti  ")
End Sub

 

[aliturkmen]

Kodları aşağıdaki gibi döngü içinde deneyebilirsin
Kodların aslına dokunmadım. Döngüye soktum ve dosyanın kopyasını kaydettim
Yine de denedim 6-7 satır için sorunsuz çalıştı.

Teşekkürler Ömer Faruk Bey,