标题：利用excel批量查询搜索关键词结果页面的网站排名

-------------------------------------------------------------------------------------------------------------------------------

时间：2011/12/9 1:54:49

-------------------------------------------------------------------------------------------------------------------------------

内容：

加入了很多人性化的修改

在a1单元格输入你要显示每个关键词的网站结果数量 从a2开始 每行都输入一个关键词

然后在vba编辑器里面输入代码

再保存 前台再拉一个按钮

里面有几个知识点

一个是利用录制宏代码 将输入的一列关键词 转成一行  符合一般习惯

利用counta里计算一行关键词的数量 count是计算数字单元格数量 counta是全部的

利用cells函数来定位 位置

Sub test()
    Dim tmp() As String, i As Integer, g As Integer, j As Integer, arr() As String, xmlhttp As Object, M&
   
        Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Range("B1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
            
    j = WorksheetFunction.CountA([1:1])
  For g = 2 To j
   
    Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
    With xmlhttp

        .Open "get", "http://www.baidu.com/s?wd=" & Cells(1, g) & "&pn=0&rn=" & Cells(1, 1), False
        .send
        tmp = Split(.responsetext, "<table")
    End With
    For i = 0 To UBound(tmp)
       If tmp(i) Like "* id=""#*""*" Then
          If Not Split(tmp(i), " id=""")(1) Like "####*" Then
             M = M + 1
             ReDim Preserve arr(1 To M)
             arr(M) = Split(Split(tmp(i), "http://")(1), "/")(0)
          End If
       End If
    Next
    Erase tmp
   Cells(2, g).Resize(UBound(arr), 1) = Application.Transpose(arr)
    Erase arr
    Set xmlhttp = Nothing
     M = 0
   
  Next

End Sub

就可以了

加入了很多人性化的修改

在a1单元格输入你要显示每个关键词的网站结果数量 从a2开始 每行都输入一个关键词

然后在vba编辑器里面输入代码

再保存 前台再拉一个按钮

里面有几个知识点

一个是利用录制宏代码 将输入的一列关键词 转成一行  符合一般习惯

利用counta里计算一行关键词的数量 count是计算数字单元格数量 counta是全部的

利用cells函数来定位 位置

Sub test()
    Dim tmp() As String, i As Integer, g As Integer, j As Integer, arr() As String, xmlhttp As Object, M&
   
        Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Range("B1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
            
    j = WorksheetFunction.CountA([1:1])
  For g = 2 To j
   
    Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
    With xmlhttp

        .Open "get", "http://www.baidu.com/s?wd=" & Cells(1, g) & "&pn=0&rn=" & Cells(1, 1), False
        .send
        tmp = Split(.responsetext, "<table")
    End With
    For i = 0 To UBound(tmp)
       If tmp(i) Like "* id=""#*""*" Then
          If Not Split(tmp(i), " id=""")(1) Like "####*" Then
             M = M + 1
             ReDim Preserve arr(1 To M)
             arr(M) = Split(Split(tmp(i), "http://")(1), "/")(0)
          End If
       End If
    Next
    Erase tmp
   Cells(2, g).Resize(UBound(arr), 1) = Application.Transpose(arr)
    Erase arr
    Set xmlhttp = Nothing
     M = 0
   
  Next

End Sub

就可以了