楼主
xmyjk |
Q:提取网页上下部分两段信息，并提取填入EXCEL两个表中，第一个填入整理后的船务信息，第二个表返回表格数据。如下图
网页：
表一：
表二：
A:使用XMLHTTP采集网页数据，并利用数组算法整理数据，最后写入单元格，并按楼主要求对采集不到的进行判断，并把采集数据的网址做成超链接。
- Option Explicit
- Sub test()
- Dim tm() As String, tmp1() As String, tmp2() As String, i As Integer, arr1(0, 4) As String, arr2(0, 1) As String, xmlhttp As Object, P As Long
- Dim li1() As String, li2() As String, arr3() As String, n As Long, blno As String, brr() As String, crr() As String, nm As Long
- Dim url As String
- On Error Resume Next
- nm = [d65536].End(3).Row + 1
- Range(Cells(2, 4), Cells(nm, 11)).ClearContents
- Worksheets(2).UsedRange.Offset(1).Clear
- Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
- For P = 2 To [c65536].End(3).Row
-
- blno = Trim(Cells(P, 3).Value)
- n = Worksheets(2).[a65536].End(3).Row + 1
- url = "http://edi.easipass.com/dataportal/query.do?ctno=&blno=" & blno & "&qn=dp_cst_vsl"
- With xmlhttp
- .Open "get", url, False
- .send
- If InStr(.responsetext, "查不到您所需要的电子装箱单") Then
- Cells(P, 4) = "查不到您所需要的电子装箱单"
- Worksheets(2).Cells(n, 1) = blno
- Worksheets(2).Cells(n, 2) = "查不到您所需要的电子装箱单"
- GoTo line1
- Else
- tm = Split(.responsetext, "</td>")
- tmp1 = Filter(tm, "<td align=""left"">")
- tmp2 = Filter(tm, "<td align=""left"" bgcolor=")
- End If
- End With
-
- For i = 0 To UBound(tmp1)
- li1() = Split(tmp1(i), ">")
- arr1(0, i Mod 5) = li1(UBound(li1))
- Next
-
- ReDim arr3(UBound(tmp2) \ 8, 8)
- ReDim brr(UBound(arr3))
- ReDim crr(UBound(arr3))
- For i = 0 To UBound(tmp2)
- li2() = Split(tmp2(i), ">")
- arr3(i \ 8, i Mod 8 + 1) = li2(UBound(li2))
- arr3(i \ 8, 0) = blno
- If i Mod 8 = 3 Then brr(i \ 8) = Int(i \ 8) + 1 & "." & li2(UBound(li2))
- If i Mod 8 = 4 Then crr(i \ 8) = Int(i \ 8) + 1 & "." & li2(UBound(li2))
- Next
- Worksheets(2).Cells(n, 1).Resize(UBound(arr3, 1) + 1, UBound(arr3, 2) + 1) = arr3
-
- arr2(0, 0) = Join(brr, vbCrLf)
- arr2(0, 1) = Join(crr, vbCrLf)
-
- Cells(P, 4).Resize(1, UBound(arr1, 2) + 1) = arr1
- Cells(P, 9).Resize(1, UBound(arr2, 2) + 1) = arr2
- ActiveSheet.Hyperlinks.Add anchor:=Cells(P, 11), Address:=url, TextToDisplay:="相关链接"
-
- Erase tmp1, tmp2, tm, li1, li2, brr, crr
- Erase arr1, arr2, arr3
-
- line1:
- Next
- Set xmlhttp = Nothing
- [C:J].Columns.AutoFit
- MsgBox "Ok"
- End Sub
 fthwps电子装箱单查询.rar
|