Цикл VBA к следующему URL после 15-20 URL начинает переопределять данные в той же ячейке. Почему он начинает помещать данные в неправильную ячейку после некоторого URL?

Question

Я пытаюсь получить данные из URL и цикла к следующему и поместить в следующий пустой столбец.все работает нормально, но после некоторых URL начинают переопределять данные в ячейке seme.

Sub pulldata()

    Dim tod As String
    Dim IE As Object
    Dim doc As HTMLDocument

    Dim Tbl As HTMLTable, Cel As HTMLTableCell, Rw As HTMLTableRow, Col As HTMLTableCol
    Dim TrgRw As Long, TrgCol As Long

    Set IE = CreateObject("InternetExplorer.Application")
    IE.Visible = True

    IE.navigate "https://nseindia.com/live_market/dynaContent/live_watch/option_chain/optionKeys.jsp?segmentLink=17&instrument=OPTIDX&symbol=NIFTY&date=25APR2019"

    Do While IE.Busy Or IE.readyState <> 4
        Application.Wait DateAdd("s", 1, Now)
    Loop

    tod = ThisWorkbook.Sheets("URLList").Range("C2").Value
    Sheets.Add After:=Sheets(Sheets.Count)

    ActiveSheet.Name = tod

    Set doc = IE.document

    For nurl = 2 To 191
        lCol = Range("IV2").End(xlToLeft).Offset(0, 0).Column

        doc.getElementById("underlyStock").Value = ThisWorkbook.Sheets("URLList").Range("A" & nurl).Value
        doc.parentWindow.execScript "goBtnClick('stock');", "javascript"

        Do While IE.Busy Or IE.readyState <> 4
            Application.Wait DateAdd("s", 1, Now)
        Loop

        strVal = Range("IV1").End(xlToLeft).Offset(0, 0).Select
        Set Tbl = doc.getElementById("octable")

        TrgRw = 1
        For Each Rw In Tbl.Rows
            TrgCol = 1
            For Each Cel In Rw.Cells
                ThisWorkbook.Sheets(tod).Cells(1, lCol).Cells(TrgRw, TrgCol).Value = Cel.innerText
                TrgCol = TrgCol + Cel.colSpan   ' if Column span is > 1 multiple
            Next Cel
            TrgRw = TrgRw + 1
        Next Rw
    Next
End Sub

Почему VBA начинает переопределять после 15-20 URL.

Answer 1

Я думаю, что это лучший вариант для сбора данных о каждой базовой вертикали, расположенной ниже пыльника. Попытка определить количество столбцов по последним данным может не дать правильный результат все время, в некоторых случаях (например, запрет производных и т. Д.) Таблица может быть пустой. В противном случае фиксированный размер столбца следует принимать для горизонтального хранилища данных.

В моем тесте данные будут показаны ниже

Код:

Sub pulldata2()
    Dim tod As String, UnderLay As String
    Dim IE As Object
    Dim doc As HTMLDocument

    Dim Tbl As HTMLTable, Cel As HTMLTableCell, Rw As HTMLTableRow, Col As HTMLTableCol
    Dim TrgRw As Long, TrgCol As Long


    tod = ThisWorkbook.Sheets("URLList").Range("C2").Value   'C2 must have proper sheet name
    have = False
    For Each sht In ThisWorkbook.Sheets
        If sht.Name = tod Then
        have = True
        Exit For
        End If
    Next sht

    If have = False Then
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = tod
    Else
    If MsgBox("Sheet " & tod & " already exists Overwrite Data?", vbYesNo) = vbNo Then Exit Sub
    End If


    Set IE = CreateObject("InternetExplorer.Application")
    IE.Visible = True
    IE.navigate "https://nseindia.com/live_market/dynaContent/live_watch/option_chain/optionKeys.jsp?segmentLink=17&instrument=OPTIDX&symbol=NIFTY&date=25APR2019"

        Do While IE.Busy Or IE.readyState <> 4
        Application.Wait DateAdd("s", 1, Now)
        Loop

    Set doc = IE.document

    TrgRw = 1
    For Nurl = 2 To 191

        UnderLay = ThisWorkbook.Sheets("URLList").Range("A" & Nurl).Value
        doc.getElementById("underlyStock").Value = UnderLay
        doc.parentWindow.execScript "goBtnClick('stock');", "javascript"

        Do While IE.Busy Or IE.readyState <> 4
            Application.Wait DateAdd("s", 1, Now)
        Loop

        'strVal = Range("IV1").End(xlToLeft).Offset(0, 0).Select
        Set Tbl = doc.getElementById("octable")

        ThisWorkbook.Sheets(tod).Cells(TrgRw, 1).Value = UnderLay  'keep as per your requirement
        ThisWorkbook.Sheets(tod).Cells(TrgRw, 1).Font.Size = 20
        ThisWorkbook.Sheets(tod).Cells(TrgRw, 1).Font.Bold = True
        ThisWorkbook.Sheets(tod).Cells(TrgRw, 1).Select
        TrgRw = TrgRw + 1


        For Each Rw In Tbl.Rows
            TrgCol = 1
            For Each Cel In Rw.Cells
                ThisWorkbook.Sheets(tod).Cells(TrgRw, TrgCol).Value = Cel.innerText
                TrgCol = TrgCol + Cel.colSpan   ' if Column span is > 1 multiple
            Next Cel
            TrgRw = TrgRw + 1
        Next Rw

    TrgRw = TrgRw + 1
    Next Nurl
End Sub

РЕДАКТИРОВАТЬ: если горизонтальная цель предпочтительнее, я могу изменить последний раздел кода следующим образом:

Set doc = IE.document

Dim ColOff As Long

For Nurl = 2 To 191
ColOff = (Nurl - 2) * 26
TrgRw = 1
    UnderLay = ThisWorkbook.Sheets("URLList").Range("A" & Nurl).Value
    doc.getElementById("underlyStock").Value = UnderLay
    doc.parentWindow.execScript "goBtnClick('stock');", "javascript"

    Do While IE.Busy Or IE.readyState <> 4
        Application.Wait DateAdd("s", 1, Now)
    Loop

    'strVal = Range("IV1").End(xlToLeft).Offset(0, 0).Select
    Set Tbl = doc.getElementById("octable")

    ThisWorkbook.Sheets(tod).Cells(TrgRw, ColOff + 1).Value = UnderLay
    ThisWorkbook.Sheets(tod).Cells(TrgRw, ColOff + 1).Font.Size = 20
    ThisWorkbook.Sheets(tod).Cells(TrgRw, ColOff + 1).Font.Bold = True
    ThisWorkbook.Sheets(tod).Cells(TrgRw, ColOff + 1).Select
    TrgRw = TrgRw + 1


    For Each Rw In Tbl.Rows
        TrgCol = 1
        For Each Cel In Rw.Cells
            ThisWorkbook.Sheets(tod).Cells(TrgRw, ColOff + TrgCol).Value = Cel.innerText
            TrgCol = TrgCol + Cel.colSpan   ' if Column span is > 1 multiple
        Next Cel
        TrgRw = TrgRw + 1
    Next Rw

TrgRw = TrgRw + 1
Next Nurl

Answer 2

Я сделал несколько небольших непроверенных изменений. Попробуйте, но это должно сработать.

Sub pulldata()
    Dim tod As String
    Dim IE As Object
    Dim doc As HTMLDocument
    Dim Tbl As HTMLTable, Cel As HTMLTableCell, Rw As HTMLTableRow, Col As HTMLTableCol
    Dim TrgRw As Long, TrgCol As Long
    Dim wk As Workbook
    Set wk = ThisWrokbook
    Set IE = CreateObject("InternetExplorer.Application")

    IE.Visible = True
    IE.navigate "https://nseindia.com/live_market/dynaContent/live_watch/option_chain/optionKeys.jsp?segmentLink=17&instrument=OPTIDX&symbol=NIFTY&date=25APR2019"

    Do While IE.Busy Or IE.readyState <> 4
        Application.Wait DateAdd("s", 1, Now)
    Loop

    tod = wk.Sheets("URLList").Range("C2").Value
    wk.Sheets.Add After:=wk.Sheets(wk.Sheets.Count)
    wk.Worksheets(wk.Sheets.Count).Name = tod
    Set doc = IE.document
    TrgRw = 1

    For nurl = 2 To 191
        lCol = wk.Sheets(tod).Range("IV2").End(xlToLeft).Offset(0, 0).Column
        doc.getElementById("underlyStock").Value = wk.Sheets("URLList").Range("A" & nurl).Value
        doc.parentWindow.execScript "goBtnClick('stock');", "javascript"

        Do While IE.Busy Or IE.readyState <> 4
            Application.Wait DateAdd("s", 1, Now)
        Loop

        strVal = wk.Sheets(tod).Range("IV1").End(xlToLeft).Offset(0, 0).Select
        Set Tbl = doc.getElementById("octable")

        For Each Rw In Tbl.Rows
            TrgCol = 1
            For Each Cel In Rw.Cells
                wk.Sheets(tod).Cells(TrgRw, TrgCol).Value = Cel.innerText
                TrgCol = TrgCol + Cel.colSpan   ' if Column span is > 1 multiple
            Next Cel
            TrgRw = TrgRw + 1
        Next Rw
    Next
End Sub