Nhờ viết dùm code vòng lập lấy data từ ngày đến ngày

Chia sẻ bởi:hands

★★★★★

‹ Hỗ trợ xử lý bài toán Dò tìm giá trị gần bằng ›

Quảng cáo

kính gửi các anh chị
em có mày mò viết vba lấy data từ web cafef.vn về, file em nó như sau:

ô B3 = mã cp
ô F3 = ngày bắt đầu (trong code em ghi là ngaybd)
ô I3 = ngày kết thúc (trong code em nghi là ngaykt)

vd ngày hiện tại em gõ = 10/11/2022, code hiện tại của em sẽ lấy data là ngày bắt đầu (10/11/2022), sau đó copy data em cần sang paste vào sheet1

nhưng em cần lấy data từ ngày đến ngày ( từ ngày bắt đầu đến ngày kết thúc) em không viết viết code sao,

em nhờ anh chị giúp em xíu, viết dùm em code vòng lập với ạ

em cảm ơn các anh chị

p/s: anh anhtuan2939 có đọc được topic của em thì giúp em với nhé, tks a ạ

Sub getmcp()
    Dim Arr As Variant
    Dim xmlReq As Object, htmlDoc As Object
    'Dim st As String, en As String
    Dim maCP As String
    '----------------------------------------------
    'On Error Resume Next
    Set xmlReq = CreateObject("MSXML2.XMLHTTP")
    Set htmlDoc = CreateObject("HTMLFile")
    Set WS = Sheets("Chitiet")
    Set st = WS.Range("F3")
    Set en = WS.Range("I3")
    dtToday = DateSerial(Year(Date), Month(Date), Day(Date))
    maCP = WS.Range("B3")
    If st = "" Or en = "" Or maCP = "" Then MsgBox "Nhap day du thong tin": Exit Sub
    lastRow = WS.Cells(Rows.Count, "B").End(xlUp).row
    If lastRow < 5 Then lastRow = 5
    WS.Range("A6:D" & lastRow).ClearContents
    stDate = DateSerial(Year(st), Month(st), Day(st))
    enDate = DateSerial(Year(en), Month(en), Day(en))
    For ngay = stDate To enDate
        lastRow = WS.Cells(Rows.Count, "B").End(xlUp).row
        If lastRow < 5 Then lastRow = 5
        If ngay < dtToday Or (ngay = dtToday And TimeValue(Now) > TimeValue("09:00:00")) Then
            Url = "s.cafef.vn/Lich-su-giao-dich-" & UCase(maCP) & "-6.chn?date=" & Format(ngay, "dd/mm/yyyy")
            With xmlReq
                .Open "GET", Url, False
                .Send
            End With
            Do While xmlReq.readyState <> 4 And xmlReq.Status <> 200
            Loop
            htmlDoc.body.innerHTML = xmlReq.responseText
            WS.Range("A" & lastRow + 1) = "=HYPERLINK(""" & Url & """,""" & ngay & """)"
            If TypeName(htmlDoc.getElementById("tblStats")) <> "HTMLTable" Or Weekday(ngay) = vbSaturday Or Weekday(ngay) = vbSunday Then
                Debug.Print "Item Not found"
                WS.Range("B" & lastRow + 1) = "Ngày không giao d" & ChrW(7883) & "ch"
            Else
                Set tblData = htmlDoc.getElementById("tblStats")       '("tblData")
                ReDim Arr(1 To tblData.Rows.Length - 1, 1 To 3)
                For i = 1 To tblData.Rows.Length - 1
                    For j = 1 To 3
                        Arr(i, j) = tblData.Rows(i).Cells(j - 1).outerText
                    Next j
                Next i
                WS.Range("B" & lastRow + 1).Resize(UBound(Arr), 3) = Arr
                Erase Arr
            End If
            '----------------------------------------------

Set tblData = Nothing
            '----------------------------------------------
        End If
    Next ngay
End Sub

Bạn tải lại file đính kèm.

www.giaiphapexcel.com/diendan/threads/nh%E1%BB%9D-vi%E1%BA%BFt-d%C3%B9m-code-v%C3%B2ng-l%E1%BA%ADp-l%E1%BA%A5y-data-t%E1%BB%AB-ng%C3%A0y-%C4%91%E1%BA%BFn-ng%C3%A0y.162992/