标题：excel导出页面url方法

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

时间：2011/12/18 0:22:50

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

内容：

同样使用vba 输入你的要的url就可以得到页面所有url的链接的文字

Sub extracturl()
    Dim tmp() As String, i As Integer, g As Integer, j As Integer, arr() As String, xmlhttp As Object, m&, url
   
   
  '      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([a:a])
  For g = 2 To j
   
    Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
    With xmlhttp
'不管带不带http一律整理为带http格式网站
url = "http://" & Replace(Cells(g, 1), "http://", "")

        .Open "get", url, False
        .send
        '分割符"
   
   'xmlhttp.responsebody = StrConv(xmlhttp.responsebody, vbUnicode, &H804)
   
        tmp = Split(.responsetext, "<a ")
       
    End With
    For i = 1 To UBound(tmp)
     
             m = m + 1
             ReDim Preserve arr(1, 1 To m)
             arr(0, m) = Split(Split(tmp(i), "href=")(1), ">")(0)
On Error Resume Next  '防止不规范的a标签 不带href 就会出错
           
            
            arr(0, m) = Replace(arr(0, m), """", "") 'remove"
            arr(0, m) = Replace(arr(0, m), "'", "") 'remove'
            arr(0, m) = Split(arr(0, m), " ")(0) 'remove space
                  
            
            
             arr(1, m) = Split(Split(tmp(i), ">")(1), "<")(0)
             arr(1, m) = Trim(arr(1, m))
   
    Next
    Erase tmp
 
  
For i = 1 To m

   Cells(i, 2) = arr(0, i)
   Cells(i, 3) = arr(1, i)
  
   Next
  
    Erase arr
    Set xmlhttp = Nothing
     m = 0
   
  Next

End Sub

a2输入url就可以了

同样使用vba 输入你的要的url就可以得到页面所有url的链接的文字

Sub extracturl()
    Dim tmp() As String, i As Integer, g As Integer, j As Integer, arr() As String, xmlhttp As Object, m&, url
   
   
  '      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([a:a])
  For g = 2 To j
   
    Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
    With xmlhttp
'不管带不带http一律整理为带http格式网站
url = "http://" & Replace(Cells(g, 1), "http://", "")

        .Open "get", url, False
        .send
        '分割符"
   
   'xmlhttp.responsebody = StrConv(xmlhttp.responsebody, vbUnicode, &H804)
   
        tmp = Split(.responsetext, "<a ")
       
    End With
    For i = 1 To UBound(tmp)
     
             m = m + 1
             ReDim Preserve arr(1, 1 To m)
             arr(0, m) = Split(Split(tmp(i), "href=")(1), ">")(0)
On Error Resume Next  '防止不规范的a标签 不带href 就会出错
           
            
            arr(0, m) = Replace(arr(0, m), """", "") 'remove"
            arr(0, m) = Replace(arr(0, m), "'", "") 'remove'
            arr(0, m) = Split(arr(0, m), " ")(0) 'remove space
                  
            
            
             arr(1, m) = Split(Split(tmp(i), ">")(1), "<")(0)
             arr(1, m) = Trim(arr(1, m))
   
    Next
    Erase tmp
 
  
For i = 1 To m

   Cells(i, 2) = arr(0, i)
   Cells(i, 3) = arr(1, i)
  
   Next
  
    Erase arr
    Set xmlhttp = Nothing
     m = 0
   
  Next

End Sub

a2输入url就可以了