标题：原创 excel公式在SEO上面的应用批量查询标题描述百度搜索结果数关键词排名 title meta baiducompetition position 汇总不定期更新12.20
-------------------------------------------------------------------------------------------------------------------------------
时间：2011/12/20 12:11:06
-------------------------------------------------------------------------------------------------------------------------------
内容：
alt+f8 打开excel编辑器 插入模块
然后保存后
就可以在单元格式使用自定义公式了
title(url) 显示url的标题 这里面做了一点设置 不管你输入的是带http还是不带的都可以识别
meta(url)同上 显示的是页面描述
baiducompeition(keywords)显示关键词在百度的搜索结果数量
'-----------------title---------
Function Title(url As String) As String
With CreateObject("Microsoft.XMLHTTP")
'防止输入的url不管带不带http都可以转换带http的
url = "http://" & Replace(url, "http://", "")
.Open "GET", url, False
.send
url = .responsetext
'源码有charset=gb或chartset="gb hao123是charset="gbk"2进制responsebody转为unicode,大小写忽略
If InStr(1, url, "charset=""gb", vbTextCompare) Or InStr(1, url, "charset=gb",
vbTextCompare) Then url = StrConv(.responseBody, vbUnicode)
'不管charact是不是gb的都okay 可以专心进行split字符串了，以上适用任何网页大小写无视
Title = Split(Split(url, "<title>", , vbTextCompare)(1), "</title>", ,
vbTextCompare)(0)
End With
End Function
'-----------------title---------
'-----------------meta---------
Function Meta(ByVal url As String) As String
On Error Resume Next
'防止输入的url不管带不带http都可以转换带http的
url = "http://" & Replace(url, "http://", "")
With CreateObject("Msxml2.XMLHTTP")
.Open "get", url, False
.send
url = .responsetext
'如果源代码中含有charset=gb或者chartset="gb ,hao123的charset="gbk"那么进行2进制代码responsebody转换为unicode
If InStr(url, "charset=""gb") Or InStr(url, "charset=gb") Then url = StrConv(.responseBody, vbUnicode)
'不管charact是不是gb的都okay 可以专心进行split（url）字符串了，以上适用任何网页
Meta = Split(Split(url, "<meta name=""description"" content=""", , vbTextCompare)(1), """")(0)
End With
End Function
'-----------------meta---------
'-----------------position---------
Function Position(keywords As String)
Dim url As String, i As Integer, tmp() As String, sourcecode As String
'去掉网址中的http和www,以及目录 防止匹配不到
url = Split(Replace(Replace(Trim(Cells(1, 1)), "http://", ""), "www.", ""), "/")(0)
With CreateObject("Msxml2.XMLHTTP")
keywords = "http://www.baidu.com/s?rn=100&word=" & keywords
.Open "get", keywords, False
.send
'去掉源代码中的sem部分
'查找第一个出现result op的代码位置 取得 后面的代码
keywords = Split(.responsetext, "id=""1""")(1)
'查找url 分组
tmp = Split(keywords, url)
'如何没找到url 输入大于100
If UBound(tmp) = 0 Then
position = ">100"
Else
'截取出现了网址后面的id的数字这是个后面排名的名次
position = Split(Split(tmp(2), "result"" id=""")(1), """")(0)
position = position - 1
End If
End With
end function
'-----------------position---------
'-----------------baiducompetition---------
Function baiducompetition(ByVal url As String) As String
On Error Resume Next
With CreateObject("Msxml2.XMLHTTP")
url = "http://www.baidu.com/s?word=" & url
.Open "get", url, False
.send
baiducompetition = Split(Split(.responsetext, "找到相关结果")(1), "个<")(0)
baiducompetition = Replace(baiducompetition, "约", "")
End With
End Function
'-----------------baiducompetition---------