[已解决]制做一个宏可以直接提取网页内ID名

imbobm · 发表于 2011-3-7 22:14

从选定的网址里提取网站的淘宝ID（只要ID，提取在表格内即可，其它不要），序号总共有六千行。

最佳答案

吕?布

2011-3-9 12:53

Option Explicit

Sub 提取淘宝ID()
Dim i As Long
Dim oHttp As Object

Dim nRow As Long
Dim cTxt As String, arr(), brr()
Dim arrTmp As Variant

On Error Resume Next
nRow = ActiveSheet.Range("e65536").End(xlUp).Row
arr = Range("E7:E" & nRow).Value
ReDim brr(7 To nRow, 1 To 1)
Set oHttp = CreateObject("Microsoft.XMLHTTP")
With oHttp
      For i = 1 To nRow
         DoEvents
         .Open "GET", arr(i, 1), False
         .Send
         Do While Not .READYSTATE = 4
            DoEvents
         Loop

         arrTmp = Split(.responsetext, "请进入")
         If IsArray(arrTmp) Then
            If UBound(arrTmp) > 0 Then
                  arrTmp = Split(arrTmp(1), "的")
                  If IsArray(arrTmp) Then
                     brr(6 + i, 1) = arrTmp(0)
                  End If
            End If
         End If
      Next
End With
Set oHttp = Nothing
ActiveSheet.Range("F7:F" & nRow).Value = brr
End Sub

提取ID.rar (18.57 KB, 下载次数: 12)

imbobm · 发表于 2011-3-7 22:15

可以的话直接联系本人，，，QQ:2189901谢谢。。金币还有。

imbobm · 发表于 2011-3-8 13:36

Sub 查询()
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next
Dim nRow%, cTxt$, ARR(), Brr()
nRow = ActiveSheet.Range("a65536").End(xlUp).Row
ARR = Range("a1:a" & nRow).Value
ReDim Brr(1 To nRow, 1 To 1)

With CreateObject("Microsoft.XMLHTTP")
      For I = 1 To nRow
         DoEvents
         .Open "POST", "htp；333sh.gov.cn/rdb/SearchOK.jsp?sfzh=" & ARR(I, 1), False
         .setRequestHeader "CONTENT-TYPE", "application/x-www-form-urlencoded"
         .Send
         Do While Not .READYSTATE = 4
            DoEvents
         Loop
         cTxt = Split(Split(Split(Split(Split(.responsetext, "<TABLE", , vbBinaryCompare)(2), "<TR>", , vbBinaryCompare)(4), "<TD", , vbBinaryCompare)(6), ">", , vbBinaryCompare)(1), "<", , vbBinaryCompare)(0)
         If Err = 0 Then Brr(I, 1) = cTxt
         Err.Clear
      Next
End With
ActiveSheet.Range("b1:b" & nRow).Value = Brr
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
利用此样版应该可以弄出来。。有高手吗？

imbobm · 发表于 2011-3-9 09:31

高手速度来。。

imbobm · 发表于 2011-3-9 09:32

Sub 提取淘宝ID()
Application.EnableEvents = False
On Error Resume Next
Dim nRow%, cTxt$, ARR(), Brr()
nRow = ActiveSheet.Range("e65536").End(xlUp).Row
ARR = Range("E7:E" & nRow).Value
ReDim Brr(7 To nRow, 7 To 1)
With CreateObject("Microsoft.XMLHTTP")
      For I = 1 To nRow
         DoEvents
         .Open "POST", ARR(I, 7), False
         .setRequestHeader "CONTENT-TYPE", "application/x-www-form-urlencoded"
         .Send
         Do While Not .READYSTATE = 4
            DoEvents
         Loop
         cTxt = Split(Split(Split(Split(Split(.responsetext, "请进入", , 1)(2), "淘宝网首页", , 1)(4), "更多充值平台加款卡", , 1)(6), "铺", , 1)(1), "的", , 1)(0)
         If Err = 0 Then Brr(I, 7) = cTxt
         Err.Clear
      Next
End With
ActiveSheet.Range("G7:G" & nRow).Value = Brr
Application.EnableEvents = True
End Sub

吕?布 · 发表于 2011-3-9 12:53

Option Explicit

Sub 提取淘宝ID()
Dim i As Long
Dim oHttp As Object

Dim nRow As Long
Dim cTxt As String, arr(), brr()
Dim arrTmp As Variant

On Error Resume Next
nRow = ActiveSheet.Range("e65536").End(xlUp).Row
arr = Range("E7:E" & nRow).Value
ReDim brr(7 To nRow, 1 To 1)
Set oHttp = CreateObject("Microsoft.XMLHTTP")
With oHttp
      For i = 1 To nRow
         DoEvents
         .Open "GET", arr(i, 1), False
         .Send
         Do While Not .READYSTATE = 4
            DoEvents
         Loop

         arrTmp = Split(.responsetext, "请进入")
         If IsArray(arrTmp) Then
            If UBound(arrTmp) > 0 Then
                  arrTmp = Split(arrTmp(1), "的")
                  If IsArray(arrTmp) Then
                     brr(6 + i, 1) = arrTmp(0)
                  End If
            End If
         End If
      Next
End With
Set oHttp = Nothing
ActiveSheet.Range("F7:F" & nRow).Value = brr
End Sub

提取ID.rar (18.57 KB, 下载次数: 12)

sunjing-zxl · 发表于 2011-3-9 13:09

我是来学习的

		自动登录	找回密码
密码			注册