Lấy dữ liệu thời tiết Accuweather để điền vào nhật ký thi công

Liên hệ QC

Bùi Thúy Thúy

Thành viên thường trực
Tham gia
2/7/18
Bài viết
289
Được thích
38
Em tham khảo được cách lấy dữ liệu lịch sử thời tiết trên Accuweather từ giaiphapexxcel.
Có vấn đề sau muốn được xin ý kiến về ý tưởng và sự chỉ giúp từ các Anh Chị:
Sau khi em lấy dữ liệu thời tiết về từ Accuweather, bài toán đặt ra như sau (4 vấn đề):
1. Chuyển định dạng cột A hoặc G về định dạng "ngày/tháng/năm" và sau khi chuyển đổi định dạng thì dữ liệu định dạng được được điền vào cột H;
2. Đem lượng mưa ở (cột C) đối chiếu với bảng 1 và sau đó điền"mưa" hay " không mưa" vào cột "Dự báo"
3. Sau đó đến cột "Thời tiết" (cột I) trong sheet "tong hợp thoi tiet" sẽ được căn cứ vào cột "Dự báo" (Cột J), nếu trong cột"Dự báo" mà trời mưa thì cột thời tiết (Cột I) là "mưa", còn nếu "không mưa" thì sẽ căn cứ vào giá trị nhiệt độ lớn nhất trong ngày ( trị số nhiệt độ đứng trước được ngăn cách bởi dấu / ở Cột B) để đối chiếu với bảng 2 và điền dữ liệu vào cột I, giá trị nhiệt độ Max, Min được lấy từ cột B(..../......) và được điền vào cột Kcột L
*** Như vậy:
- Dữ liệu sau khi điền vào cột "dự báo" (Cột J) sẽ là: "mưa" hoặc "không mưa"
- Dữ liệu được điền vào cột "thời tiết" (Cột I) sẽ có : "mưa" hoặc " Nắng" hoặc "Bình thường"hoặc "Rét đậm, rét hại"
- Dữ liệu nhiệt độ Max, Min sẽ được điền vào tương ứng cột L cột K
4. Dữ liệu "Thời tiết" (Cột R) ở các ngày từ "sheet 1" đến "Sheet n" sẽ được lấy từ cột I của Sheet "Tong hop thoi tiet" và được điền vào (cột R) các ngày tương ứng từ sheet 1 đến Sheet n
Em xin cám ơn! và mong được sự đóng góp và chỉ bảo của các Thầy, các Anh, Chị.
tiet.jpg
 

File đính kèm

  • ok thoi tiet.xlsb
    49.8 KB · Đọc: 419
Lần chỉnh sửa cuối:
Em lên trang Web Copy thủ công về ạ. Cực lắm chị ạ. Chị giúp em cái Code tạo phần ấy được không ạ

Đó thực sự là 1 nỗ lực tuyệt vời, cho thấy sự kiên trì, bền bỉ tuyệt vời. Bạn có những đức tính ấy thì sẽ sớm trở thành chuyên gia rất giỏi.
Mình thấy hổ thẹn không được như bạn. Mình cũng không biết có cách nào tạo ra phần đó bằng code.
 
Upvote 0
Đó thực sự là 1 nỗ lực tuyệt vời, cho thấy sự kiên trì, bền bỉ tuyệt vời. Bạn có những đức tính ấy thì sẽ sớm trở thành chuyên gia rất giỏi.
Mình thấy hổ thẹn không được như bạn. Mình cũng không biết có cách nào tạo ra phần đó bằng code.
Chị ơi. Chị ơi... em vào GPE (cũng khoảng 2 năm rùi mà ). Em cũng đọc rất nhiều bài của chị (À không phải. Bài của Anh kia). Qua đó em cũng vọc vạch trả lời trên diễn đàn để thực tập các kiến thức mình đã học được. Mong Chị yêu quý giúp đỡ bọn em với (*). Em cám ơn chị nhiều
(*) Chị không giúp là em mách thầy em đóa. Mà có lần Thầy em bẩu Chị là "Tên lười bướng nhấc máy" :p:p:p
 
Lần chỉnh sửa cuối:
Upvote 0
Chị ơi. Chị ơi... em vào GPE (cũng khoảng 2 năm rùi mà ). Em cũng đọc rất nhiều bài của chị (À không phải. Bài của Anh kia). Qua đó em cũng vọc vạch trả lời trên diễn đàn để thực tập các kiến thức mình đã học được. Mong Chị yêu quý giúp đỡ bọn em với (*). Em cám ơn chị nhiều
(*) Chị không giúp là em mách thầy em đóa. Mà có lần Thầy em bẩu Chị là "Tên lười bướng nhấc máy":p:p:p

Ủa chị này, anh kia là gì vậy bạn ? mình không hiểu bạn đang nói về điều gì ?
Nay mình được nghỉ nên vào nghịch chơi, lấy danh sách các trạm gì đó.
Lâu quá không viết mấy cái này, chắc lạc hậu với các bạn ở đây rồi.

Mã:
Public Sub hello()
Dim arrTinh, arrTram, arrGop, x As Long, y As Long, k As Long
arrTinh = dichNoiDungUlHtml(layNoiDungWeb("https://www.accuweather.com/vi/browse-locations/asi/vn"))
ReDim arrGop(1 To 100 * UBound(arrTinh), 1 To 3)
For x = 1 To UBound(arrTinh) Step 1
    arrTram = dichNoiDungUlHtml(layNoiDungWeb(arrTinh(x, 1)))
    For y = 1 To UBound(arrTram) Step 1
        k = k + 1
        arrGop(k, 1) = arrTinh(x, 2)
        arrGop(k, 2) = arrTram(y, 2)
        arrGop(k, 3) = arrTram(y, 1)
        'Exit For
    Next
    'Exit For
Next
Sheet123456789.Range("A2").Resize(UBound(arrGop), UBound(arrGop, 2)).Value = arrGop
End Sub

Private Function layNoiDungWeb(ByVal duongdan As String) As String
Dim req As Object
Set req = CreateObject("msxml2.xmlhttp")
req.Open "GET", duongdan, False
req.send
layNoiDungWeb = req.responsetext
Set req = Nothing
End Function

Private Function dichNoiDungUlHtml(ByVal noidung As String)
Static reg As Object
Dim lPos As Long, lEnd As Long
Dim mats As Object, arr, r As Long
If reg Is Nothing Then
    Set reg = CreateObject("VBScript.RegExp")
    reg.IgnoreCase = True
    reg.Pattern = "a href=""([^""]+)""><em>([^<]+)"
    reg.Global = True
End If
lPos = InStr(1, noidung, "<ul class=""articles")
lEnd = InStr(lPos, noidung, "</ul>")
noidung = Mid(noidung, lPos, lEnd - lPos + 5)

Set mats = reg.Execute(noidung)
If mats.Count > 0 Then
    ReDim arr(1 To mats.Count, 1 To 2)
    For r = 1 To UBound(arr) Step 1
        arr(r, 1) = mats(r - 1).submatches(0)
        arr(r, 2) = dichHexHtml(mats(r - 1).submatches(1))
    Next
End If
dichNoiDungUlHtml = arr
End Function

Private Function dichHexHtml(ByVal content As String) As String
Static doc As Object
If doc Is Nothing Then Set doc = CreateObject("Msxml2.DOMDocument")
doc.LoadXML "<root>" & content & "</root>"
dichHexHtml = doc.Text
End Function
 
Upvote 0
Ủa chị này, anh kia là gì vậy bạn ? mình không hiểu bạn đang nói về điều gì ?
Nay mình được nghỉ nên vào nghịch chơi, lấy danh sách các trạm gì đó.
Lâu quá không viết mấy cái này, chắc lạc hậu với các bạn ở đây rồi.

Mã:
Public Sub hello()
Dim arrTinh, arrTram, arrGop, x As Long, y As Long, k As Long
arrTinh = dichNoiDungUlHtml(layNoiDungWeb("https://www.accuweather.com/vi/browse-locations/asi/vn"))
ReDim arrGop(1 To 100 * UBound(arrTinh), 1 To 3)
For x = 1 To UBound(arrTinh) Step 1
    arrTram = dichNoiDungUlHtml(layNoiDungWeb(arrTinh(x, 1)))
    For y = 1 To UBound(arrTram) Step 1
        k = k + 1
        arrGop(k, 1) = arrTinh(x, 2)
        arrGop(k, 2) = arrTram(y, 2)
        arrGop(k, 3) = arrTram(y, 1)
        'Exit For
    Next
    'Exit For
Next
Sheet123456789.Range("A2").Resize(UBound(arrGop), UBound(arrGop, 2)).Value = arrGop
End Sub

Private Function layNoiDungWeb(ByVal duongdan As String) As String
Dim req As Object
Set req = CreateObject("msxml2.xmlhttp")
req.Open "GET", duongdan, False
req.send
layNoiDungWeb = req.responsetext
Set req = Nothing
End Function

Private Function dichNoiDungUlHtml(ByVal noidung As String)
Static reg As Object
Dim lPos As Long, lEnd As Long
Dim mats As Object, arr, r As Long
If reg Is Nothing Then
    Set reg = CreateObject("VBScript.RegExp")
    reg.IgnoreCase = True
    reg.Pattern = "a href=""([^""]+)""><em>([^<]+)"
    reg.Global = True
End If
lPos = InStr(1, noidung, "<ul class=""articles")
lEnd = InStr(lPos, noidung, "</ul>")
noidung = Mid(noidung, lPos, lEnd - lPos + 5)

Set mats = reg.Execute(noidung)
If mats.Count > 0 Then
    ReDim arr(1 To mats.Count, 1 To 2)
    For r = 1 To UBound(arr) Step 1
        arr(r, 1) = mats(r - 1).submatches(0)
        arr(r, 2) = dichHexHtml(mats(r - 1).submatches(1))
    Next
End If
dichNoiDungUlHtml = arr
End Function

Private Function dichHexHtml(ByVal content As String) As String
Static doc As Object
If doc Is Nothing Then Set doc = CreateObject("Msxml2.DOMDocument")
doc.LoadXML "<root>" & content & "</root>"
dichHexHtml = doc.Text
End Function
Em cám ơn Chị rất nhiều. Chúc Chị và Gia đình có 1 kỳ lễ vui vẻ và Hạnh phúc
 
Upvote 0
Upvote 0
Hình như là chỉ lấy được được qua khứ 2 năm thôi và tương lai là 5 ngày thì phải. Mà chỉ được ó 63 tỉnh thôi. Mất mất 1 tỉnh rồi :p:p:p
 
Upvote 0
Upvote 0
Ủa chị này, anh kia là gì vậy bạn ? mình không hiểu bạn đang nói về điều gì ?
Nay mình được nghỉ nên vào nghịch chơi, lấy danh sách các trạm gì đó.
Lâu quá không viết mấy cái này, chắc lạc hậu với các bạn ở đây rồi.

Mã:
Public Sub hello()
Dim arrTinh, arrTram, arrGop, x As Long, y As Long, k As Long
arrTinh = dichNoiDungUlHtml(layNoiDungWeb("https://www.accuweather.com/vi/browse-locations/asi/vn"))
ReDim arrGop(1 To 100 * UBound(arrTinh), 1 To 3)
For x = 1 To UBound(arrTinh) Step 1
    arrTram = dichNoiDungUlHtml(layNoiDungWeb(arrTinh(x, 1)))
    For y = 1 To UBound(arrTram) Step 1
        k = k + 1
        arrGop(k, 1) = arrTinh(x, 2)
        arrGop(k, 2) = arrTram(y, 2)
        arrGop(k, 3) = arrTram(y, 1)
        'Exit For
    Next
    'Exit For
Next
Sheet123456789.Range("A2").Resize(UBound(arrGop), UBound(arrGop, 2)).Value = arrGop
End Sub

Private Function layNoiDungWeb(ByVal duongdan As String) As String
Dim req As Object
Set req = CreateObject("msxml2.xmlhttp")
req.Open "GET", duongdan, False
req.send
layNoiDungWeb = req.responsetext
Set req = Nothing
End Function

Private Function dichNoiDungUlHtml(ByVal noidung As String)
Static reg As Object
Dim lPos As Long, lEnd As Long
Dim mats As Object, arr, r As Long
If reg Is Nothing Then
    Set reg = CreateObject("VBScript.RegExp")
    reg.IgnoreCase = True
    reg.Pattern = "a href=""([^""]+)""><em>([^<]+)"
    reg.Global = True
End If
lPos = InStr(1, noidung, "<ul class=""articles")
lEnd = InStr(lPos, noidung, "</ul>")
noidung = Mid(noidung, lPos, lEnd - lPos + 5)

Set mats = reg.Execute(noidung)
If mats.Count > 0 Then
    ReDim arr(1 To mats.Count, 1 To 2)
    For r = 1 To UBound(arr) Step 1
        arr(r, 1) = mats(r - 1).submatches(0)
        arr(r, 2) = dichHexHtml(mats(r - 1).submatches(1))
    Next
End If
dichNoiDungUlHtml = arr
End Function

Private Function dichHexHtml(ByVal content As String) As String
Static doc As Object
If doc Is Nothing Then Set doc = CreateObject("Msxml2.DOMDocument")
doc.LoadXML "<root>" & content & "</root>"
dichHexHtml = doc.Text
End Function
Chị cho em hỏi code này có tâc dụng gi vậy ạ? em chạy thấy báo lỗi ạ?
loi.png
 
Lần chỉnh sửa cuối:
Upvote 0
Vâng ạ! ở dòng thứ 6 kết hợp ô A6 và G6 thì dữ liệu ô H6 sẽ là ngày sẽ là 10/10/2017 nhưng em thấy định dạng là 1/10/2017
Cảm ơn anh!

Xin chào chị E có tìm kiếm trên Web và thấy bài của chị không biết hiện tại chị đã có được file excel lấy được lịch sử thời tiết chưa? chị có thể gưi cho em xin được không? Email: theksgt@gmail.com e cảm ơn ạ
 
Upvote 0
Lỗi này là thế nào ạ. xin mọi người chỉ giúp
1587084463266.png
 
Upvote 0
Em không rõ về vba, cho em hỏi sửa đoạn mã bị lỗi như này như nào ạ. em cảm ơn các bác ạ


Sub Thoitiet()
UserForm_TT.Show
End Sub
Sub ShowURL()
Dim rng As Object, cel As Range
Set rng = Range("B2:B583")
If TypeOf rng Is Range Then
For Each cel In rng
If cel.Hyperlinks.Count Then cel.Offset(, 1).Value = cel.Hyperlinks(1).Address
Next
End If
End Sub
Sub GetdatawebAccuweather(ByVal Tram As String, fDate As Date, eDate As Date)
Application.ScreenUpdating = False
Dim hrq As Object, html As Object, url As String, dated As Date, row As Object, cell As Object, a As Object, reg As Object, Str As String, id As String
Dim I As Long, j As Long, k As Long, nmonth As Long, wf As WorksheetFunction, url2 As String, url3 As String, id2 As String, lcal As String
Dim dArr(), R As Long
Set wf = WorksheetFunction: Set hrq = CreateObject("msxml2.xmlhttp"): Set html = CreateObject("htmlfile")
url = "https://www.accuweather.com/vi/vn/thai-binh/356177/january-weather/356177?monyr="
R = Range("A" & Rows.Count).End(xlUp).row + 1
If R > 5 Then Range("A5:G" & R).Clear
R = eDate - fDate + 1: ReDim dArr(1 To R, 1 To 8)
With hrq
.Open "POST", "https://www.accuweather.com/vi/search-locations", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send "s=" & Tram
Do While .readystate <> 4
DoEvents
Loop
html.body.innerhtml = .responsetext
'MsgBox InStr(1, .responsetext, Tram)
End With
Dim RX As Object
Set RX = CreateObject("vbscript.regexp")
RX.Pattern = "^(?:https://www.accuweather.com)/.+/(\w+)/[^\/]+/(\w+)$": RX.Global = True
For Each a In html.getelementsbytagname("a")
If RX.test(a.href) And (a.innertext Like "*" & Tram & "*" Or a.innertext Like "*" & Split(Tram, ",")(0) & "*") Then '
id = RX.Replace(a.href, "$1")
id2 = RX.Replace(a.href, "$2")
End If
Next
RX.Global = True
RX.Pattern = "\/\d+"
url2 = Replace(Replace(RX.Replace(url, "@@"), "@@", "/" & id, , 1), "@@", "/" & id2)
For nmonth = 0 To DateDiff("m", wf.EoMonth(fDate, -1) + 1, wf.EoMonth(eDate, 0) + 1)
url3 = url2 & Format(wf.eDate(fDate, nmonth), "m/d/yyyy") & "&view=table"
With hrq
.Open "GET", url3, 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(fDate, nmonth)))
If dated >= fDate And dated <= eDate Then
I = I + 1: j = 0: k = k + 1
For Each cell In row.Cells
j = j + 1
dArr(I, j) = cell.innertext:
Next
dArr(I, 7) = dated
dArr(I, 5) = Accuweather(dArr(I, 2), 1)
dArr(I, 8) = Accuweather(dArr(I, 3), 2)
End If
Next
Next nmonth
Range("A5").Resize(k, 8) = dArr
Range("A5").Resize(k, 8).Borders.LineStyle = 1
Set hrq = Nothing: Set html = Nothing
Application.ScreenUpdating = True
MsgBox "Done!"
Set RX = Nothing
End Sub
 

File đính kèm

  • Ma cod bao loi file lay thoi tiet tren web1.jpg
    Ma cod bao loi file lay thoi tiet tren web1.jpg
    87.2 KB · Đọc: 15
Upvote 0
Bạn xem thử cái này. Bao gồm 64 tỉnh thành :p:p:p
Chị ơi, em nhập mà cứ bị báo lỗi T_T có cách nào ko ạ
Em không rõ về vba, cho em hỏi sửa đoạn mã bị lỗi như này như nào ạ. em cảm ơn các bác ạ


Sub Thoitiet()
UserForm_TT.Show
End Sub
Sub ShowURL()
Dim rng As Object, cel As Range
Set rng = Range("B2:B583")
If TypeOf rng Is Range Then
For Each cel In rng
If cel.Hyperlinks.Count Then cel.Offset(, 1).Value = cel.Hyperlinks(1).Address
Next
End If
End Sub
Sub GetdatawebAccuweather(ByVal Tram As String, fDate As Date, eDate As Date)
Application.ScreenUpdating = False
Dim hrq As Object, html As Object, url As String, dated As Date, row As Object, cell As Object, a As Object, reg As Object, Str As String, id As String
Dim I As Long, j As Long, k As Long, nmonth As Long, wf As WorksheetFunction, url2 As String, url3 As String, id2 As String, lcal As String
Dim dArr(), R As Long
Set wf = WorksheetFunction: Set hrq = CreateObject("msxml2.xmlhttp"): Set html = CreateObject("htmlfile")
url = "https://www.accuweather.com/vi/vn/thai-binh/356177/january-weather/356177?monyr="
R = Range("A" & Rows.Count).End(xlUp).row + 1
If R > 5 Then Range("A5:G" & R).Clear
R = eDate - fDate + 1: ReDim dArr(1 To R, 1 To 8)
With hrq
.Open "POST", "https://www.accuweather.com/vi/search-locations", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send "s=" & Tram
Do While .readystate <> 4
DoEvents
Loop
html.body.innerhtml = .responsetext
'MsgBox InStr(1, .responsetext, Tram)
End With
Dim RX As Object
Set RX = CreateObject("vbscript.regexp")
RX.Pattern = "^(?:https://www.accuweather.com)/.+/(\w+)/[^\/]+/(\w+)$": RX.Global = True
For Each a In html.getelementsbytagname("a")
If RX.test(a.href) And (a.innertext Like "*" & Tram & "*" Or a.innertext Like "*" & Split(Tram, ",")(0) & "*") Then '
id = RX.Replace(a.href, "$1")
id2 = RX.Replace(a.href, "$2")
End If
Next
RX.Global = True
RX.Pattern = "\/\d+"
url2 = Replace(Replace(RX.Replace(url, "@@"), "@@", "/" & id, , 1), "@@", "/" & id2)
For nmonth = 0 To DateDiff("m", wf.EoMonth(fDate, -1) + 1, wf.EoMonth(eDate, 0) + 1)
url3 = url2 & Format(wf.eDate(fDate, nmonth), "m/d/yyyy") & "&view=table"
With hrq
.Open "GET", url3, 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(fDate, nmonth)))
If dated >= fDate And dated <= eDate Then
I = I + 1: j = 0: k = k + 1
For Each cell In row.Cells
j = j + 1
dArr(I, j) = cell.innertext:
Next
dArr(I, 7) = dated
dArr(I, 5) = Accuweather(dArr(I, 2), 1)
dArr(I, 8) = Accuweather(dArr(I, 3), 2)
End If
Next
Next nmonth
Range("A5").Resize(k, 8) = dArr
Range("A5").Resize(k, 8).Borders.LineStyle = 1
Set hrq = Nothing: Set html = Nothing
Application.ScreenUpdating = True
MsgBox "Done!"
Set RX = Nothing
End Sub
em cũng bị tương tự. có ai giúp bọn em với ạ
 
Upvote 0
Web KT
Back
Top Bottom