Lấy dữ liệu từ Website vào Excel

Liên hệ QC
PacificPR

PacificPR

Thành viên mới
Tham gia
6/5/16
Bài viết
1,997
Được thích
2,747
Xin chào các Anh (Chị):
Kính mong Anh(Chị) viết dùm em Code lấy dữ liệu từ Website vào Excel
Hiện tại em đang muốn lấy thông tin thời tiết từ ngày ... đến ngày ... tại trang https://www.accuweather.com vào trong Exel để lấy thông tin ngày mưa của địa phương mà công trình thi công.
Như File đính kèm thì ô B2 là ngày bắt đầu, ô D2 là ngày kết thúc và ô B3 là đường Link của địa phương công trình đang thi công nhưng chưa biết hướng giải quyết phải như thế nào.
Em xin chân thành cảm ơn./
 

File đính kèm

  • Thong tin thoi tiet.xls
    43.5 KB · Đọc: 99
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Sử dụng Data, From Web là được nè.
Cho kết quả vào sheet tạm, rồi mình xử lý mở hỗn độn đó theo ý muốn. :D

upload_2018-1-5_17-12-54.png
 
Upvote 0
PacificPR đã viết:
Xin chào các Anh (Chị):
Kính mong Anh(Chị) viết dùm em Code lấy dữ liệu từ Website vào Excel
Hiện tại em đang muốn lấy thông tin thời tiết từ ngày ... đến ngày ... tại trang https://www.accuweather.com vào trong Exel để lấy thông tin ngày mưa của địa phương mà công trình thi công.
Như File đính kèm thì ô B2 là ngày bắt đầu, ô D2 là ngày kết thúc và ô B3 là đường Link của địa phương công trình đang thi công nhưng chưa biết hướng giải quyết phải như thế nào.
Em xin chân thành cảm ơn./
Nhấp chuột vào đây để mở rộng...
Cái này khả năng lấy được, khi nào rảnh mình thử sức xem thế nào. Lấy dữ liệu web thì mình thấy có 2 bác này làm tốt doveandrose và Autoreply
 
Upvote 0
Em có tìm được Code này
PHP: 
Option Explicit
Sub HTMLTable()
    Dim htm As Object
    Dim Tr As Object
    Dim Td As Object
    Dim Tab1 As Object
    Dim URL As String
    Dim Colstart As Long
    Dim HTML As Variant
    Dim i As Long
    Dim j As Long
    Dim n As Long
Application.ScreenUpdating = False
URL = VBA.Trim(Sheets(1).Cells(3, 2))
Set HTML = CreateObject("htmlfile")
With CreateObject("msxml2.xmlhttp")
    .Open "GET", URL, False
    .send
    HTML.Body.Innerhtml = .responseText
End With
Colstart = 1
j = 5
i = Colstart
n = 0

For Each Tab1 In HTML.getElementsByTagName("table")
    With HTML.getElementsByTagName("table")(n)
        For Each Tr In .Rows
            For Each Td In Tr.Cells
                Sheet1.Cells(j, i) = Td.innerText
                i = i + 1
            Next Td
            i = Colstart
            j = j + 1
        Next Tr
    End With
    n = n + 1
    i = Colstart
    j = j + 1
Next Tab1
Application.ScreenUpdating = True
End Sub
Nhờ Anh (Chị) sửa dùm em cho Code trên lấy dữ liệu theo tháng mình nhập vào ô B2 và D2 Không ạ

Em Cám ơn các Anh(Chị rất nhiều)
 

File đính kèm

  • Thong tin thoi tiet (1).xls
    49.5 KB · Đọc: 33
Lần chỉnh sửa cuối:
Upvote 0
PacificPR đã viết:
Xin chào các Anh (Chị):
Kính mong Anh(Chị) viết dùm em Code lấy dữ liệu từ Website vào Excel
Hiện tại em đang muốn lấy thông tin thời tiết từ ngày ... đến ngày ... tại trang https://www.accuweather.com vào trong Exel để lấy thông tin ngày mưa của địa phương mà công trình thi công.
Như File đính kèm thì ô B2 là ngày bắt đầu, ô D2 là ngày kết thúc và ô B3 là đường Link của địa phương công trình đang thi công nhưng chưa biết hướng giải quyết phải như thế nào.
Em xin chân thành cảm ơn./
Nhấp chuột vào đây để mở rộng...
Bạn thử code này xem:
PHP: 
Sub getdataweb()
Application.ScreenUpdating = False
Dim hrq As Object, html As Object, url As String, str As String, result, result1, dated As Date
Dim i As Long, j As Long, k As Long, nmonth As Long, wf As WorksheetFunction
Set wf = WorksheetFunction
Set hrq = CreateObject("msxml2.xmlhttp")
Set html = CreateObject("htmlfile")
[a4:g65000].Clear
With CreateObject("vbscript.regexp")
    .Global = True: .Pattern = "^(.+\s(\d{2}\/\d{2}))((.+°)(\d{1,2}\smm)(\d{1,2}\sCM)\s?(\D*))?(.+)$"
    For nmonth = 0 To DateDiff("m", wf.EoMonth([b1], -1) + 1, wf.EoMonth([d1], 0) + 1)
        url = "https://www.accuweather.com/vi/vn/thai-binh/356177/january-weather/356177?monyr=" _
        & Format(wf.EDate([b1], nmonth), "m/d/yyyy") & "&view=table"
        With hrq
            .Open "GET", url, False
            .send
            Do While .readystate <> 4
                DoEvents
            Loop
           html.body.innerhtml = .responsetext
        End With
        result = Split(html.getelementsbytagname("table")(0).innertext, vbNewLine)
        ReDim result1(1 To UBound(result) + 1, 1 To 7): k = 0
        For i = 1 To UBound(result1) - 1
            dated = DateValue(Trim(.Replace(result(i), "$2")) & "/" & Year(wf.EDate([b1], nmonth)))
            If dated >= [b1] And dated <= [d1] Then
                k = k + 1
                result1(k, 2) = .Replace(result(i), "$1"): result1(k, 3) = .Replace(result(i), "$4")
                result1(k, 4) = .Replace(result(i), "$5"): result1(k, 5) = .Replace(result(i), "$6")
                result1(k, 7) = Trim(.Replace(result(i), "$8")): result1(k, 1) = Format(wf.EDate([b1], nmonth), "mm/yyyy")
                result1(k, 6) = .Replace(result(i), "$7")
            End If
        Next i
        If k Then [a3].Offset([A65000].End(xlUp).Row - 2).Resize(k, 7) = result1
    Next nmonth
End With
[a4].CurrentRegion.Borders.LineStyle = 1
Set hrq = Nothing
Set html = Nothing
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
 

File đính kèm

  • Thong tin thoi tiet (1).xlsb
    34.1 KB · Đọc: 75
Lần chỉnh sửa cuối:
Upvote 0
PacificPR đã viết:
Kết quả thật là tuyệt vời quá :yahoo:. Em cám ơn Anh @excel_lv1.5, Anh @befaint. Thầy @VetMin và Chị @NguyenNgocThuHien rất nhiều ạ. Chúc mọi người 1 ngày cuối tuần vui vẻ và hạnh phúc./
Nhấp chuột vào đây để mở rộng...
Cái lấy dữ liệu thời tiết này hay quá bác PacificPR ơi, tuy nhiên em tải file của bác excel_lv1.5 thì không chạy nhưng rất chậm. Bác Up lại file lên giúp em với được không? Em xin cảm ơn
 
Lần chỉnh sửa cuối:
Upvote 0
PacificPR đã viết:
Em có tìm được Code này
PHP: 
Option Explicit
Sub HTMLTable()
    Dim htm As Object
    Dim Tr As Object
    Dim Td As Object
    Dim Tab1 As Object
    Dim URL As String
    Dim Colstart As Long
    Dim HTML As Variant
    Dim i As Long
    Dim j As Long
    Dim n As Long
Application.ScreenUpdating = False
URL = VBA.Trim(Sheets(1).Cells(3, 2))
Set HTML = CreateObject("htmlfile")
With CreateObject("msxml2.xmlhttp")
    .Open "GET", URL, False
    .send
    HTML.Body.Innerhtml = .responseText
End With
Colstart = 1
j = 5
i = Colstart
n = 0

For Each Tab1 In HTML.getElementsByTagName("table")
    With HTML.getElementsByTagName("table")(n)
        For Each Tr In .Rows
            For Each Td In Tr.Cells
                Sheet1.Cells(j, i) = Td.innerText
                i = i + 1
            Next Td
            i = Colstart
            j = j + 1
        Next Tr
    End With
    n = n + 1
    i = Colstart
    j = j + 1
Next Tab1
Application.ScreenUpdating = True
End Sub
Nhờ Anh (Chị) sửa dùm em cho Code trên lấy dữ liệu theo tháng mình nhập vào ô B2 và D2 Không ạ

Em Cám ơn các Anh(Chị rất nhiều)
Nhấp chuột vào đây để mở rộng...
Dựa vào code của bạn
Mã: 
Dim arr(1 To 1000, 1 To 6), n As Long
Sub main()
    Dim datefilter As Date, diffmonth As Integer, darr(1 To 1000, 1 To 6)
    Dim startday, endday As Long, i, j, k As Long
    Range("A5:F2000").Clear
    diffmonth = DateDiff("m", Cells(2, 2), Cells(2, 4))
    n = 1
    For k = 0 To diffmonth
        Call HTMLTable("https://www.accuweather.com/vi/vn/thai-binh/356177/march-weather/356177?monyr=", Format(DateAdd("m", k, Cells(2, 2)), "m/d/yyyy"))
    Next
    For i = 1 To UBound(arr)
        If arr(i, 1) <> "" Then
        If Val(Right(Split(arr(i, 1), "/")(0), 2)) = Day(Cells(2, 2)) Then
            startday = i
            Exit For
        End If
        End If
    Next
    For i = UBound(arr) To 1 Step -1
        If arr(i, 1) <> "" Then
        If Val(Right(Split(arr(i, 1), "/")(0), 2)) = Day(Cells(2, 4)) Then
            endday = i
            Exit For
        End If
        End If
    Next
    For i = startday To endday
        j = j + 1
        For k = 1 To 6
            darr(j, k) = arr(i, k)
        Next
    Next
    Range("A5").Resize(1000, 6) = darr
End Sub

Sub HTMLTable(url As String, month As String)
    Dim htm As Object
    Dim Tr As Object
    Dim Td As Object
    Dim Tab1 As Object
    Dim url1 As String
    Dim Colstart As Long
    Dim HTML As Variant
    Dim r, c As Integer
    url1 = url & month & "&view=table"
    Set HTML = CreateObject("htmlfile")
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", url1, False
        .send
        Do While .readystate <> 4
            DoEvents
        Loop
        HTML.Body.Innerhtml = .responseText
    End With
    With HTML.getElementsByTagName("table")(0)
        For r = 1 To .Rows.Length - 1
            For c = 0 To .Rows(r).Cells.Length - 1
                arr(n, c + 1) = .Rows(r).Cells(c).innerText
            Next
            n = n + 1
        Next
    End With
End Sub
 
Upvote 0
quanluu1989 đã viết:
Dựa vào code của bạn
Mã: 
Dim arr(1 To 1000, 1 To 6), n As Long
Sub main()
    Dim datefilter As Date, diffmonth As Integer, darr(1 To 1000, 1 To 6)
    Dim startday, endday As Long, i, j, k As Long
    Range("A5:F2000").Clear
    diffmonth = DateDiff("m", Cells(2, 2), Cells(2, 4))
    n = 1
    For k = 0 To diffmonth
        Call HTMLTable("https://www.accuweather.com/vi/vn/thai-binh/356177/march-weather/356177?monyr=", Format(DateAdd("m", k, Cells(2, 2)), "m/d/yyyy"))
    Next
    For i = 1 To UBound(arr)
        If arr(i, 1) <> "" Then
        If Val(Right(Split(arr(i, 1), "/")(0), 2)) = Day(Cells(2, 2)) Then
            startday = i
            Exit For
        End If
        End If
    Next
    For i = UBound(arr) To 1 Step -1
        If arr(i, 1) <> "" Then
        If Val(Right(Split(arr(i, 1), "/")(0), 2)) = Day(Cells(2, 4)) Then
            endday = i
            Exit For
        End If
        End If
    Next
    For i = startday To endday
        j = j + 1
        For k = 1 To 6
            darr(j, k) = arr(i, k)
        Next
    Next
    Range("A5").Resize(1000, 6) = darr
End Sub

Sub HTMLTable(url As String, month As String)
    Dim htm As Object
    Dim Tr As Object
    Dim Td As Object
    Dim Tab1 As Object
    Dim url1 As String
    Dim Colstart As Long
    Dim HTML As Variant
    Dim r, c As Integer
    url1 = url & month & "&view=table"
    Set HTML = CreateObject("htmlfile")
    With CreateObject("msxml2.xmlhttp")
        .Open "GET", url1, False
        .send
        Do While .readystate <> 4
            DoEvents
        Loop
        HTML.Body.Innerhtml = .responseText
    End With
    With HTML.getElementsByTagName("table")(0)
        For r = 1 To .Rows.Length - 1
            For c = 0 To .Rows(r).Cells.Length - 1
                arr(n, c + 1) = .Rows(r).Cells(c).innerText
            Next
            n = n + 1
        Next
    End With
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ. Em cám ơn @quanluu1989 nhiều ạ
 
Upvote 0
PacificPR đã viết:
Em có tìm được Code này
PHP: 
Option Explicit
Sub HTMLTable()
    Dim htm As Object
    Dim Tr As Object
    Dim Td As Object
    Dim Tab1 As Object
    Dim URL As String
    Dim Colstart As Long
    Dim HTML As Variant
    Dim i As Long
    Dim j As Long
    Dim n As Long
Application.ScreenUpdating = False
URL = VBA.Trim(Sheets(1).Cells(3, 2))
Set HTML = CreateObject("htmlfile")
With CreateObject("msxml2.xmlhttp")
    .Open "GET", URL, False
    .send
    HTML.Body.Innerhtml = .responseText
End With
Colstart = 1
j = 5
i = Colstart
n = 0

For Each Tab1 In HTML.getElementsByTagName("table")
    With HTML.getElementsByTagName("table")(n)
        For Each Tr In .Rows
            For Each Td In Tr.Cells
                Sheet1.Cells(j, i) = Td.innerText
                i = i + 1
            Next Td
            i = Colstart
            j = j + 1
        Next Tr
    End With
    n = n + 1
    i = Colstart
    j = j + 1
Next Tab1
Application.ScreenUpdating = True
End Sub
Nhờ Anh (Chị) sửa dùm em cho Code trên lấy dữ liệu theo tháng mình nhập vào ô B2 và D2 Không ạ

Em Cám ơn các Anh(Chị rất nhiều)
Nhấp chuột vào đây để mở rộng...
Tôi chỉnh lại code này của bạn chút:
PHP: 
Sub getdataweb()
Application.ScreenUpdating = False
Dim hrq As Object, html As Object, url As String, dated As Date, row As Object, cell As Object
Dim i As Long, j As Long, k As Long, nmonth As Long, wf As WorksheetFunction
Set wf = WorksheetFunction
Set hrq = CreateObject("msxml2.xmlhttp")
Set html = CreateObject("htmlfile")
[a6:g65000].Clear
For nmonth = 0 To DateDiff("m", wf.EoMonth([b2], -1) + 1, wf.EoMonth([d2], 0) + 1)
    url = "https://www.accuweather.com/vi/vn/thai-binh/356177/january-weather/356177?monyr=" _
    & Format(wf.EDate([b2], nmonth), "m/d/yyyy") & "&view=table"
    With hrq
        .Open "GET", url, False
        .send
        Do While .readystate <> 4
            DoEvents
        Loop
       html.body.innerhtml = .responsetext
    End With
    For Each row In html.getelementsbytagname("tbody")(0).Rows
        dated = DateValue(Split(Trim(row.Cells(0).innertext), " ")(1) & "/" & Year(wf.EDate([b2], nmonth)))
        If dated >= [b2] And dated <= [d2] Then
            i = i + 1: j = 0
            For Each cell In row.Cells
                j = j + 1
                Cells(i + 5, j) = cell.innertext: Cells(i + 5, 7) = Format(wf.EDate([b2], nmonth), "mm/yyyy")
            Next
        End If
    Next
Next nmonth
[a6].CurrentRegion.Borders.LineStyle = 1
Set hrq = Nothing
Set html = Nothing
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

S
Hỏi cách nhập dữ liệu vào 1 ô trả kết quả ở 1 ô khác có công thức
Trả lời
9
Đọc
156
Hoàng Tuấn 868
H
pingping2288
Lỗi cứ lần mở lại file excel là font chữ và định dạng ô lại thay đổi
Trả lời
14
Đọc
125
Hoàng Tuấn 868
H
vova2209
  • Question
Tìm địa chỉ ô với 2đk và chuyển thành links
Trả lời
14
Đọc
231
vova2209
vova2209
H
  • Question
Xóa toàn bộ các dòng giống nhau ở 1 cột
    • Cười
Trả lời
12
Đọc
97
hadoan-pap
H
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
7 8 9
Trả lời
164
Đọc
8K
chstbcaolanh
C
T
Đánh Số Thứ Tự Loại Bỏ Trùng
Trả lời
1
Đọc
32
bebo021999
B
H
Có thể mở file Excel mới sẽ Zoom mặc định 150% không?
Trả lời
4
Đọc
167
VetMini
V
O
  • Question
Tìm số thứ tự của sheet trong workbook có nhiều sheets
Trả lời
11
Đọc
3K
VetMini
V
Manhhung90
Liệt kê các ngày cộng dồn mong muốn vào 1 ô. Nhờ mọi người giúp mình ạ.
2 3 4
Trả lời
62
Đọc
748
VetMini
V
C
Hàm đánh số thứ tự như không đánh dữ liệu trùng
Trả lời
7
Đọc
8K
Trang Tuyet Ngoc Nhi
T
Hai Lúa Miền Tây
  • Question
Hàm chuyển dữ liệu từ cột sang dòng (Hàm melt + wide_to_long của Python trong Excel)
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
9
Đọc
470
tranhungdao12a3
T
GPE-Trợ Lý
Đăng ký tham dự hội thảo tại Hà Nội: Power Query - Công cụ quản lý dữ liệu
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
4
Đọc
469
PhanTuHuong
PhanTuHuong
tvcneo
  • Question
Nhờ Anh Chị Em giúp mình cách để tạo macro giống như trong file này
Trả lời
17
Đọc
232
huuthang_bd
huuthang_bd
T
Có phải lỗi Excel?
Trả lời
8
Đọc
9K
dinhthang8709
D
T
Công thức lấy dữ liệu
Trả lời
3
Đọc
124
HUONGHCKT
H
S
  • Question
Nhờ anh chị giúp em hàm ngẫu nhiên với tổng là 1 số
Trả lời
6
Đọc
150
SA_DQ
SA_DQ
L
Tự động nhảy số tham chiếu khi sang sheet mới
Trả lời
5
Đọc
5K
Romantic92
R
TieuLong2708
Danh sách lịch cắt người trực
Trả lời
0
Đọc
38
TieuLong2708
TieuLong2708
C
  • Question
Xin giúp đỡ Code kiểm tra và copy dữ liệu từ sheet 1 sang sheet 2
2
Trả lời
21
Đọc
628
conan1
C
H
  • Question
Mong giúp code chuyển file xls sang xlsx hàng loạt và không lỗi số liệu
Trả lời
16
Đọc
378
Hoàng Tuấn 868
H
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom