求修改代码，谢谢

ykcbf1100

taller 发表于 2025-12-16 23:35
To 草爷：

这部分代码有个小bug，第一行代码将”星期日“替换为”星期一“，最后一行再次被替换为”星 ...

谢谢指正，已修复星期显示问题

ykcbf1100

87009997 发表于 2025-12-17 00:19
数据没有按要求提取到sheet1表格内

我看错题意了，我只提取天气预报
反正有别人写了代码，我就不改了。

ykcbf1100

1. Sub 获取天气()
   
2.     Dim shp As Shape, URL$, str1$, str2$, str3$, today$
   
3.     Dim i As Integer, xm As Variant, rq As Date, xq As String
   
4.     Dim nf As Integer  ' 当前年份
   
5.     Application.ScreenUpdating = False
   
6.     Cells.UnMerge
   
7.     Range("D2:K" & Rows.Count).ClearContents
   
8.     For Each shp In ActiveSheet.Shapes
   
9.         If shp.Type <> 1 Then shp.Delete
   
10.     Next
    
11.     URL = "http://www.15tianqi.com/" & getpy(Range("B2").Value) & "/"
    
12.     With CreateObject("MSXML2.XMLHTTP")
    
13.         .Open "GET", URL, False
    
14.         .setRequestHeader "Connection", "keep-alive"
    
15.         .send
    
16.         str1 = .responsetext
    
17.         str3 = "<table>" & Split(Split(str1, Range("B2").Value & "今日天气预报</dt>")(1), "</td>")(0) & "</td></table>"
    
18.         str2 = "<table" & Split(Split(str1, "<table")(3), "</table>")(0) & "</table>"
    
19.         str2 = Replace(str2, "/Images", "http://www.15tianqi.com/Images")
    
20.         str3 = Replace(str3, "/Images", "http://www.15tianqi.com/Images")
    
21.         ' 调整str2从当天开始
    
22.         today = Format(Date, "M") & "月" & Format(Date, "d") & "日"
    
23.         nf = Year(Date)  ' 当前年份
    
24.         Dim pos As Long: pos = InStr(1, str2, today)
    
25.         If pos > 0 Then
    
26.             Dim trStart As Long: trStart = InStrRev(str2, "<tr>", pos)
    
27.             If trStart > 0 Then
    
28.                 Dim headerEnd As Long: headerEnd = InStr(1, str2, "</tr>") + 5
    
29.                 If headerEnd > 5 Then
    
30.                     str2 = Left(str2, headerEnd) & Mid(str2, trStart)
    
31.                 End If
    
32.             End If
    
33.         End If
    
34.         CopyToClipbox str2
    
35.         ActiveSheet.Paste Destination:=Range("D2")
    
36.         CopyToClipbox str3
    
37.         ActiveSheet.Paste Destination:=Range("K3")
    
38.         Range("K1") = Range("B2") & "今日天气"
    
39.         Range("D1") = "★" & Range("B2") & "未来15天天气预报★"
    
40.         ' 修正15天预报表格中的星期（从D3开始的日期行）
    
41.         For i = 3 To 17
    
42.             If Trim(Cells(i, 4).Value) = "" Then Exit For
    
43.             xm = Split(Trim(Cells(i, 4).Value))
    
44.             If UBound(xm) >= 0 Then
    
45.                 Dim monthStr As String: monthStr = Replace(xm(0), "月", "")
    
46.                 monthStr = Split(monthStr, "日")(0)
    
47.                 Dim targetDay As Integer: targetDay = Val(Split(xm(0), "日")(0))
    
48.                 On Error Resume Next
    
49.                 rq = CDate(nf & "年" & xm(0))
    
50.                 If Err.Number <> 0 Then
    
51.                     Err.Clear
    
52.                     rq = CDate(nf + 1 & "年" & xm(0))  ' 跨年时自动使用下一年
    
53.                 End If
    
54.                 On Error GoTo 0
    
55.                 xq = Format(rq, "aaaa")
    
56.                 Cells(i, 4).Value = xm(0) & " " & xq
    
57.             End If
    
58.         Next i
    
59.     End With
    
60.     Range("B5").Select
    
61.     Application.ScreenUpdating = True
    
62. End Sub
    
63. 
    
64. Sub CopyToClipbox(strText As String)
    
65.     With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    
66.         .SetText strText
    
67.         .PutInClipboard
    
68.     End With
    
69. End Sub
    

复制代码