Question

我一直在尝试编写VBA代码来复制这三个表，如下面的Web源代码所示。这些表显示了每月的天气数据。有人可以帮我写一个代码来复制这些数据并将其粘贴到Excel表格中吗？我编写了一个VBA代码来访问此数据，但无法复制和粘贴此数据。非常感谢你提前。

网页源代码：

 </table>
</div>
<hr><big><b><i>Parameters for Sizing and Pointing of Solar Panels and for Solar Thermal Applications:</i></b></big>
<hr width="80%">
<a name="clr_sky"></a>
<div align="center"><table border=1 summary="Monthly Averaged Clear Sky Insolation Incident On A Horizontal Surface " width="95%">
<caption><b>Monthly Averaged Clear Sky Insolation Incident On A Horizontal Surface (kWh/m<sup>2</sup>/day)</b></caption><tr><td>Lat 32 <br> Lon 75</td>
<td>Jan</td><td>Feb</td><td>Mar</td><td>Apr</td><td>May</td><td>Jun</td>
<td>Jul</td><td>Aug</td><td>Sep</td><td>Oct</td><td>Nov</td><td>Dec</td>
<td>Annual<br>Average</td></tr>
<tr><td>22-year Average     </td><td align="center" nowrap>4.17</td><td align="center" nowrap>5.29</td><td align="center" nowrap>6.64</td><td align="center" nowrap>7.92</td><td align="center" nowrap>8.65</td><td align="center" nowrap>8.78</td><td align="center" nowrap>8.31</td><td align="center" nowrap>7.48</td><td align="center" nowrap>6.60</td><td align="center" nowrap>5.63</td><td align="center" nowrap>4.44</td><td align="center" nowrap>3.82</td><td align="center" nowrap>6.48</td>
</tr></table></div>
<div align="center"><b><i>
<a href="/sse/text/definitions.html#clr_sky" onClick="window.open('/sse/text/definitions.html#clr_sky','Definitions','menubar=yes,resizable=yes,scrollbars=yes,toolbar=yes,width=600,height=400'); return false">Parameter Definition</a> &nbsp;  &nbsp;  &nbsp;  &nbsp;  &nbsp;

</i></b></div>
<hr width="80%">
<a name="clr_kt"></a>
<div align="center"><table border=1 summary="Monthly Averaged Clear Sky Insolation Clearness Index " width="95%">
<caption><b>Monthly Averaged Clear Sky Insolation Clearness Index (0 to 1.0)</b></caption><tr><td>Lat 32 <br> Lon 75</td>
<td>Jan</td><td>Feb</td><td>Mar</td><td>Apr</td><td>May</td><td>Jun</td>
<td>Jul</td><td>Aug</td><td>Sep</td><td>Oct</td><td>Nov</td><td>Dec</td>
</tr>
<tr><td>22-year Average     </td><td align="center" nowrap>0.75</td><td align="center" nowrap>0.76</td><td align="center" nowrap>0.76</td><td align="center" nowrap>0.77</td><td align="center" nowrap>0.77</td><td align="center" nowrap>0.76</td><td align="center" nowrap>0.73</td><td align="center" nowrap>0.71</td><td align="center" nowrap>0.72</td><td align="center" nowrap>0.75</td><td align="center" nowrap>0.75</td><td align="center" nowrap>0.74</td>
</tr></table></div>
<div align="center"><b><i>
<a href="/sse/text/definitions.html#clr_kt" onClick="window.open('/sse/text/definitions.html#clr_kt','Definitions','menubar=yes,resizable=yes,scrollbars=yes,toolbar=yes,width=600,height=400'); return false">Parameter Definition</a> &nbsp;  &nbsp;  &nbsp;  &nbsp;  &nbsp;

</i></b></div>
<hr><big><b><i>Meteorology (Other):</i></b></big>
<hr width="80%">
<a name="col_precip"></a>
<div align="center"><table border=1 summary="Monthly Averaged Total Column Precipitable Water " width="95%">
<caption><b>Monthly Averaged Total Column Precipitable Water (cm)</b></caption><tr><td>Lat 32 <br> Lon 75</td>
<td>Jan</td><td>Feb</td><td>Mar</td><td>Apr</td><td>May</td><td>Jun</td>
<td>Jul</td><td>Aug</td><td>Sep</td><td>Oct</td><td>Nov</td><td>Dec</td>
<td>Annual<br>Average</td></tr>
<tr><td>22-year Average     </td><td align="center" nowrap>0.66</td><td align="center" nowrap>0.76</td><td align="center" nowrap>0.97</td><td align="center" nowrap>1.18</td><td align="center" nowrap>1.49</td><td align="center" nowrap>2.19</td><td align="center" nowrap>3.28</td><td align="center" nowrap>3.31</td><td align="center" nowrap>2.20</td><td align="center" nowrap>1.08</td><td align="center" nowrap>0.74</td><td align="center" nowrap>0.66</td><td align="center" nowrap>1.54</td>
</tr></table></div>
<div align="center"><b><i>
<a href="/sse/text/definitions.html#col_precip" onClick="window.open('/sse/text/definitions.html#col_precip','Definitions','menubar=yes,resizable=yes,scrollbars=yes,toolbar=yes,width=600,height=400'); return false">Parameter Definition</a> &nbsp;  &nbsp;  &nbsp;  &nbsp;  &nbsp;

我写的是：

Set elemCollection = IE.Document.getElementsByTagname("table")

For t = 0 To (elemCollection.Length - 1)
    For r = 0 To (elemCollection(t).Rows.Length - 1)
        For c = 0 To (elemCollection(t).Rows(r).Cells.Length - 1)

        ThisWorkbook.Worksheets(1).Cells(r + 1, c + 1) = elemCollection(t).Rows(r).Cells(c).innertext
        Next c
        Next r
        Next t

End With

Set IE = Nothing

但是，电子表格中没有数据。能否请您说明代码有什么问题？谢谢！

根据Jeeped的建议，我尝试了这段代码：

Sub extractSolData()
Dim IE As Object
Dim r As Integer, c As Integer, t As Integer
Dim iTD As Long, iTR As Long, eTR As MSHTML.IHTMLElement, ecTRs As IHTMLElementCollection

Set IE = CreateObject("InternetExplorer.Application")

latitude = InputBox("Enter Latitude of the location")
longitude = InputBox("Enter Longitude of the location")

With IE
IE.Visible = True
IE.navigate ("https://eosweb.larc.nasa.gov/cgi-bin/sse/grid.cgi?email=skip@larc.nasa.gov")

While IE.readyState <> 4
DoEvents
Wend

IE.document.getElementsByName("lat").Item.innerText = latitude
IE.document.getElementsByName("lon").Item.innerText = longitude

IE.document.getElementsByName("submit").Item.Click
Do While IE.Busy: DoEvents: Loop

For Each obj In IE.document.all.Item("swv_dwn").Options
If obj.Value = "clr_sky" Then
obj.Selected = True
End If

If obj.Value = "clr_kt" Then
obj.Selected = True
End If
Next obj

For Each obj In IE.document.all.Item("RH10M").Options
If obj.Value = "col_precip" Then
obj.Selected = True
End If
Next obj

IE.document.getElementsByName("submit").Item.Click
Do While IE.Busy: DoEvents: Loop

If CBool(IE.document.getElementsByTagName("table").Length) Then
    For iTBL = 0 To (IE.document.getElementsByTagName("table").Length - 1)
        Set ecTRs = IE.document.getElementsByTagName("table")(iTBL).getElementsByTagName("tr")
        For iTR = 0 To (ecTRs.Length - 1)
            If CBool(ecTRs(iTR).getElementsByTagName("th").Length) Then
                For iTD = 0 To (ecTRs(iTR).getElementsByTagName("th").Length - 1)
                    ThisWorkbook.Sheets("Sheet1").Cells(iTR + 1, iTD + 1) = ecTRs(iTR).getElementsByTagName("th")(iTD).innerText
                Next iTD
            ElseIf CBool(ecTRs(iTR).getElementsByTagName("td").Length) Then
                For iTD = 0 To (ecTRs(iTR).getElementsByTagName("td").Length - 1)
                    ThisWorkbook.Sheets("Sheet1").Cells(iTR + 1, iTD + 1) = ecTRs(iTR).getElementsByTagName("td")(iTD).innerText
                Next iTD
            End If
        Next iTR
        Set ecTRs = Nothing
    Next iTBL
End If
End With
Set IE = Nothing

End Sub

但是，没有数据被复制到excel文件中。

Answer 1

目前还不清楚您使用什么方法来访问网页，但这里是一个XMLHTTP示例，它遍历网页的所有表并将单元格值返回给Sheet1。

Dim htmlBDY As HTMLDocument, xmlHTTP As New MSXML2.ServerXMLHTTP60
Dim iTD As Long, iTR As Long, iTBL As Long, eTR As MSHTML.IHTMLElement, ecTRs As IHTMLElementCollection
xmlHTTP.Open "POST", "https://eosweb.larc.nasa.gov/cgi-bin/sse/grid.cgi", False
xmlHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
'this post string uses the sample data on the form page. You can concatenate a string var to do the same thing
xmlHTTP.send "email=skip@larc.nasa.gov&step=1&lat=33.5&lon=-80.75"

Set htmlBDY = New HTMLDocument
htmlBDY.body.innerHTML = xmlHTTP.responseText

If CBool(htmlBDY.getElementsByTagName("table").Length) Then
    For iTBL = 0 To (htmlBDY.getElementsByTagName("table").Length - 1)
        Set ecTRs = htmlBDY.getElementsByTagName("table")(iTBL).getElementsByTagName("tr")
        For iTR = 0 To (ecTRs.Length - 1)
            If CBool(ecTRs(iTR).getElementsByTagName("th").Length) Then
                For iTD = 0 To (ecTRs(iTR).getElementsByTagName("th").Length - 1)
                    Sheet1.Cells(iTR + 1, iTD + 1) = ecTRs(iTR).getElementsByTagName("th")(iTD).innerText
                Next iTD
            ElseIf CBool(ecTRs(iTR).getElementsByTagName("td").Length) Then
                For iTD = 0 To (ecTRs(iTR).getElementsByTagName("td").Length - 1)
                    Sheet1.Cells(iTR + 1, iTD + 1) = ecTRs(iTR).getElementsByTagName("td")(iTD).innerText
                Next iTD
            End If
        Next iTR
        Set ecTRs = Nothing
    Next iTBL
End If

Set htmlBDY = Nothing
Set xmlHTTP = Nothing

我正在使用XMLHTTP方法将表单数据发布到CGI表单中。您不太可能使用基于浏览器的方法直接访问该页面。 InternetExplorer.Application方法可能必须转到表单，填写并提交以进入同一页面。此外，与XMLHTTP相比，加载浏览器对象的开销（和时间）是巨大的。

MSXML2.ServerXMLHTTP60 Form Submission

您需要浏览工具►参考，并将 Microsoft Internet Controls，Microsoft HTML Object library 和 Microsoft XML 6.0 添加到您的项目中。

请注意，我正在检查＆lt; th＆gt;和＆lt; td＆gt; ＆lt; tr＆gt;中的元素。可以想象至少有一个级别的错误控制，但我从来没有真正看到任何＆lt; table＆gt;没有至少一个＆lt; tr＆gt;。

POST网站表单数据和检索结果

1 个答案: