如何用Excel进行网页数据采集

excel采集互联网信息

用EXCEL采集网页信息，其实并不难，需要开启宏功能，用VBA编写采集代码，就可以将信息采集到表格里了。

Function ReadWeb(strURL)

以下是关键代码：编写一个采集函数

 ' MsgBox strURL

  'Range("H2").Value = strURL

  t = Timer '开始计时

  tt = t

  nm = Left(Range("J3").Value, 2) &Range("J4").Value

  url2 = "https://**.com.cn/**.php?symbol=" &nm 

  Set objWeb = CreateObject("MSXML2.XMLHTTP") 'Microsoft.XMLHTTP

  objWeb.Open "Get", strURL, False, "", ""

  objWeb.send

  arrBytes = CStr(objWeb.responseBody) 

  mytime2 = mytime2 + Timer - tt '计时 

   

  strReturn = "州桐闷" '以下将二进制数据流转换册弯为中文文本

  For i = 1 To LenB(arrBytes)

      Chr1 = AscB(MidB(arrBytes, i, 1))

   

      If Chr1 <&轮启H80 Then

          strReturn = strReturn &Chr(Chr1)

          Else

          Chr2 = AscB(MidB(arrBytes, i + 1, 1))

          strReturn = strReturn &Chr(CLng(Chr1) * &H100 + CInt(Chr2))

          i = i + 1

      End If

  Next i

     ReadWeb = strReturn

End Function

一、数据采集系统功能 录入、保存、查询老友、清空、修改

二、两个界面

1.数据录入界面：前台功能使用界面，实现“录入、保存、查询、清空、修改”；

2. 数据存储界面：后台实现数据的保存； 录入界面：

三、实现方法 1. 保存功能 Sub Save() '

'保存数据 Marco，xiaohou制作，时间2013-9-5 '

Dim r1, r2, r3 As Range With Sheets("数据存储")

Set r2 = .Range("a2", .[a100000].End(xlUp)) End With

With Sheets("数据录入")   Set r1 = .Range("c4:e4, d6:l39")

If IsEmpty(.Range("c4")) Or IsEmpty(.Range("e4")) Then     'Or IsEmpty(.Range("b7:b41")) 添加科室不为空，未成功     MsgBox ("编码、名称为空，不可保存！")   Else

Set r3 = r2.Find(.Cells(4, 3), , , 1)     If Not r3 Is Nothing Then

MsgBox ("此编码已存在，不可保存。如果此信息需要修改，请点击查询后再修改")

Else

Sheets("数据存储").Rows("2:35").Insert Shift:=xlDown    

.Range("c6:l39").Copy  '复制“数据录入”表体信息

Sheets("数据存储").Range("c2:l2").PasteSpecial Paste:=xlPasteValues       .Range("c4").Copy      '复制“数据录入”编码

Sheets("数据存储").Range("a2:a35").PasteSpecial Paste:=xlPasteValues       .Range("e4").Copy      '复制“数据录侍颂槐入”名称

Sheets("数据存储").Range("b2:b35").PasteSpecial Paste:=xlPasteValues       r1.ClearContents       '保存数据后，清空录入界面    

.Range("c4").Select     End If   End If End With End Sub

2. 查询功能 Sub Query() '

' 查询筛选 Macro，xiaohou制作，时间2013-9-5 ' '

Dim Erow As Integer Dim r1, r2 As Range With Sheets("数据录入")   Set r1 = .Range("d6:l39")   Set r2 = .Range("a6:b39")

Erow = Sheets("数据存储").[a100000].End(xlUp).Row  

r1.ClearContents  

'For Each ce In .[a2:x2]

'If ce <>"" Then ce.Value = "*" &ce &"*"   '加上通配符*,实现模糊查樱弯询  

'Next

If IsEmpty(.Range("c4")) Or IsEmpty(.Range("e4")) Then  

'Or IsEmpty(.Range("b7:b41")) 添加科室不为空，未成功  

MsgBox ("编码、名称为空，不可查询！")   Else

Sheets("数据存储").Range("A1:l" &Erow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _     .[c3:e4], CopyToRange:=.[A5:l5], Unique:=False

r2.Borders(xlDiagonalDown).LineStyle = xlNone     r2.Borders(xlDiagonalUp).LineStyle = xlNone  

r2.Borders(xlEdgeLeft).LineStyle = xlNone  

r2.Borders(xlEdgeTop).LineStyle = xlNone  

r2.Borders(xlEdgeBottom).LineStyle = xlNone  

'r2.Borders(xlEdgeRight).LineStyle = xlNone     r2.Borders(xlInsideVertical).LineStyle = xlNone

r2.Borders(xlInsideHorizontal).LineStyle = xlNone  

r2.NumberFormatLocal = ""  

'For Each ce In .[a2:x2]

'If ce <>"" Then ce.Value = Mid(ce, 2, Len(ce) - 2)   '取消 "*"通配符

'Next   End If End With End Sub

3. 更新 Sub Update() '

'更新 Macro，xiaohou制作，时间2013-9-5    

Dim arr, d As Object    

Dim r As Range    

Dim lr&, i&, j%    

With Sheets("数据录入") '查询修改工作表数据区域写入数组arr        

'arr = .Range("A7:D" &.Range("A65536").End(xlUp).Row)        

arr = .Range("a6:l39")        

Set r = .Range("d6:l39")    

End With

Set d = CreateObject("scripting.dictionary") '定义字典对象    

For i = 1 To UBound(arr) '逐行

      'If Len(arr(i, 2)) <>0 Then '排出“合计”行，即：姓名务数据

          If Not d.exists(arr(i, 1) &arr(i, 2) &arr(i, 3)) Then d(arr(i, 1) &arr(i, 2) &arr(i, 3)) = arr(i, 4) &Chr(9) &arr(i, 5) _

          &Chr(9) &arr(i, 6) &Chr(9) &arr(i, 7) &Chr(9) &arr(i, 8) &Chr(9) &arr(i, 9) &Chr(9) &arr(i, 10) &Chr(9) &arr(i, 11) &Chr(9) &arr(i, 12)

'上一句：如果编码和名称连接字符串字典不存在(首次出现，这里判断可能多余)，这个字符串添加到字典键值，后续的相关属性字段用制表符连接添加到字典条目      

'End If      Next

   With Sheets("数据存储")

   lr = .Range("A100000").End(xlUp).Row '数据存储工作表数据行数

'.Range("C2:D" &lr).SpecialCells(xlCellTypeConstants, 23).ClearContents '清除C、D列不含公式单元格的值

arr = .Range("A2:l" &lr) '数据存储工作表数据区域写入数组arr    

For i = 1 To UBound(arr) '逐行

If d.exists(arr(i, 1) &arr(i, 2) &arr(i, 3)) Then '如果编码和名称连接字符串字典存在，即Sheet2中有          

For j = 4 To 12 'D、E、F...列逐列

'If Not Cells(i, j).HasFormula Then Cells(i, j) = Split(d(arr(i, 1) &arr(i, 2)), Chr(9))(j - 3)              

'上句：如果单元格不含公式，把Sheet2对应的数据写入这个单元格

.Cells(i + 1, j) = Split(d(arr(i, 1) & arr(i, 2) & arr(i, 3)), Chr(9))(j - 4)

Next

End If

Next

End With

r.ClearContents

Sheets("

数据录入

").Cells(4, 3).Select

MsgBox ("

数据已更新完成，若要查看更新后的内容，请点击按钮查询")

---