第一辑、网页：点击标签，翻页

lqh123108

多谢分享，太牛了。。。。

蓝天630902

一劳永逸地把所以标签全查一遍，
查找标签:

蓝天630902

为了让没有注册本论坛的兄弟们方便，还是把代码贴出来：

Sub 查找标签innerText()
    Dim arr
    [a1:cm1] = Split("标签号,a,abbr,acronym,address,applet,area,b,base,basefont,bdo,big,blockquote,body,br,button,caption,center,cite,code,col,colgroup,dd,del,dfn,dir,div,dl,dt,em,fieldset,font,form,frame,frameset,head,h1,h2,h3,h4,h5,h6,hr,html,i,iframe,img,input,ins,kbd,label,legend,li,link,map,menu,meta,noframes,noscript,object,ol,optgroup,option,p,param,pre,q,s,samp,script,select,small,span,strike,strong,style,sub,sup,table,tbody,td,textarea,tfoot,th,thead,title,tr,tt,u,ul,var", ",")
    Application.ScreenUpdating = False
    Cells.EntireColumn.Hidden = False
    s = 0
    For p = 1 To 91
        If Cells(2, p) > s Then s = Cells(2, p)
    Next p
    Rows("2:" & s + 3).Delete Shift:=xlUp
    arr = Range(Cells(1, 2), Cells(1, 91))
    With CreateObject("InternetExplorer.Application")
        .Visible = True
        .Navigate "http://de.yusuan.com/index.html"
        Do Until .ReadyState = 4
            DoEvents
        Loop
        For p = 1 To 90
            str1 = arr(1, p)
            Set r = .Document.All.tags(str1)
            Cells(2, p + 1) = r.Length
            For i = 0 To r.Length - 1 '标签的个数
                Cells(i + 3, 1) = i
                Cells(i + 3, p + 1) = r(i).innerText '把第ｉ个标签的内容写入第ｉ+3行，2 * p列
            Next i
        Next p
        .Quit
    End With
    Columns("A:A").Columns.AutoFit
    Rows("1:2").Columns.AutoFit
    For p = 1 To 91
    If Cells(2, p + 1) = 0 Then Columns(p + 1).EntireColumn.Hidden = True
    Next p
    Application.ScreenUpdating = True
    MsgBox "ok"
End Sub

还有查找标签的name的：

Sub 查找标签name()
    Dim arr
    On Error Resume Next
    [a1:cm1] = Split("标签号,a,abbr,acronym,address,applet,area,b,base,basefont,bdo,big,blockquote,body,br,button,caption,center,cite,code,col,colgroup,dd,del,dfn,dir,div,dl,dt,em,fieldset,font,form,frame,frameset,head,h1,h2,h3,h4,h5,h6,hr,html,i,iframe,img,input,ins,kbd,label,legend,li,link,map,menu,meta,noframes,noscript,object,ol,optgroup,option,p,param,pre,q,s,samp,script,select,small,span,strike,strong,style,sub,sup,table,tbody,td,textarea,tfoot,th,thead,title,tr,tt,u,ul,var", ",")
    Application.ScreenUpdating = False
    Cells.EntireColumn.Hidden = False
    s = 0
    For p = 1 To 91
        If Cells(2, p) > s Then s = Cells(2, p)
    Next p
    Rows("2:" & s + 3).Delete Shift:=xlUp
    arr = Range(Cells(1, 2), Cells(1, 91))
    With CreateObject("InternetExplorer.Application")
        .Visible = True
        .Navigate "http://de.yusuan.com/index.html"
        Do Until .ReadyState = 4
            DoEvents
        Loop
        For p = 1 To 90
            str1 = arr(1, p)
            Set r = .Document.All.tags(str1)
            Cells(2, p + 1) = r.Length
            For i = 0 To r.Length - 1 '标签的个数
                Cells(i + 3, 1) = i
                Cells(i + 3, p + 1) = r(i).Name '把第ｉ个标签名写入第ｉ+3行，2 * p列
            Next i
        Next p
        .Quit
    End With
    Columns("A:A").Columns.AutoFit
    Rows("1:2").Columns.AutoFit
    For p = 1 To 91
    If Cells(2, p + 1) = 0 Then Columns(p + 1).EntireColumn.Hidden = True
    Next p
    Application.ScreenUpdating = True
    MsgBox "ok"
End Sub

goldowl2011

Good codes.Thanks a lot.

蓝天630902

也有不灵光的地方，比如说下面的网址：
http://www.tjcae.com/rtjsj/index.htm
但是，网页页面的源码里面，有一个iframe行内框架，这个框架的src（地址）为：“/ShareSubjectList/tradePublicInfo.jsp”也就是“http://www.tjcae.com/ShareSubjectList/tradePublicInfo.jsp”
用这个网址，按照上面的方法得出，“input”的“name”属性为“tradeDateInput”

Sub 天津文化艺术品交易所交易公开信息()
    On Error Resume Next
    With CreateObject("internetexplorer.application")
        .Visible = True
        .Navigate "http://www.tjcae.com/ShareSubjectList/tradePublicInfo.jsp"
        Do Until .ReadyState = 4
            DoEvents
        Loop
        .Document.All.tags("INPUT")(0).Value = "2012-05-28"
        .Document.All.tags("INPUT")(1).Click
    End With
End Sub

----------------------------------
不过本问题无需点击标签，更直接的方法就是：
Sub 天津文化艺术品交易所交易公开信息()
    On Error Resume Next
    With CreateObject("internetexplorer.application")
        .Visible = True
        .Navigate "http://www.tjcae.com/ShareSubjectList/tradePublicInfo.jsp?tradeDateInput=2012-05-28"
        Do Until .ReadyState = 4
            DoEvents
        Loop
    End With
End Sub

蓝天630902

再比如说，http://club.excelhome.net/forum-2-1.html
如何点击“选择主题分类”选择框中的“求助、分享、讨论、原创、推荐、转帖、2007、已解决”

Sub ExcelVBA程序开发ExcelHome论坛灌水机()
    On Error Resume Next
    With CreateObject("internetexplorer.application")
        .Visible = True
        .Navigate "http://club.excelhome.net/forum-2-1.html"
        Do Until .ReadyState = 4
            DoEvents
        Loop
        .Document.All.tags("li")(1).Click '  求助
        '.Document.All.tags("li")(2).Click '  分享
        '.Document.All.tags("li")(3).Click '  讨论
        '.Document.All.tags("li")(4).Click '  原创
        '.Document.All.tags("li")(5).Click '  推荐
        '.Document.All.tags("li")(6).Click '  转帖
        '.Document.All.tags("li")(7).Click '  2007
        '.Document.All.tags("li")(8).Click '  已解决
    End With
End Sub

申明：不可以用本代码去灌水，谁违反本申明，后果自负。

蓝天630902

Sub 跳到网易论坛末页()
    On Error Resume Next
    With CreateObject("internetexplorer.application")
        .Visible = True
        .Navigate "http://bbs.news.163.com/bbs/mil/1193698.html"
        Do Until .ReadyState = 4
            DoEvents
        Loop
        While .ReadyState <> 4 Or .Busy
            DoEvents
        Wend
        .Document.All.tags("img")(20).Click
        Set r = .Document.All.tags("a")
        For i = 0 To r.Length
            If Left(r(i).innerText, 2) = "末页" Then
                r(i).Click
                Exit For
            End If
        Next i
    End With
End Sub

蓝天630902

'网页翻页:

'1、可以在网址里面更改页码来翻页，比如：
'“http://club.excelhome.net/thread-849179-5-1.html”
'可以改变上面的红色的“5”来翻页，这个比较简单。

Sub 验证码识别直接判断()
    On Error Resume Next
    With CreateObject("internetexplorer.application")
        .Visible = True
        For p = 1 To 6 '更改页码来翻页
        .Navigate "http://club.excelhome.net/thread-849179-" & p & "-1.html"
        While .ReadyState <> 4 Or .Busy
            DoEvents
        Wend
        Next p
    End With
End Sub

蓝天630902

'网页翻页:

'也可以按照前面的方法，通过点击标签来翻页：
'2、点击标签来翻页，比如：

Sub 价格查询1()
    On Error Resume Next
    With CreateObject("internetexplorer.application")
        .Visible = True
        .Navigate "http://www.dq123.com/price/priceindex.aspx"
            While .ReadyState <> 4 Or .Busy
                DoEvents
            Wend
            Set r = .Document.All.tags("table")(7).Rows
            n = Range("a65536").End(xlUp).Row
            For i = 0 To r.Length - 1
                For j = 0 To r(i).Cells.Length - 1
                If j > 0 And j < 3 Then
                    Cells(i + n + 1, j + 1) = r(i).Cells(j).Title
                Else
                    Cells(i + n + 1, j + 1) = r(i).Cells(j).innerText
                End If
                Next j
            Next i
        For p = 1 To 36639
        Set r1 = .Document.All.tags("a")
        s = r1.Length - 18
       .Document.All.tags("a")(s).Click '点击“下一页”标签翻页
            While .ReadyState <> 4 Or .Busy
                DoEvents
            Wend
            Set r = .Document.All.tags("table")(7).Rows
            n = Range("a65536").End(xlUp).Row
            For i = 0 To r.Length - 1
                For j = 0 To r(i).Cells.Length - 1
                If j > 0 And j < 3 Then
                    Cells(i + n + 1, j + 1) = r(i).Cells(j).Title
                Else
                    Cells(i + n + 1, j + 1) = r(i).Cells(j).innerText
                End If
                Next j
            Next i
       Next p
    End With
End Sub

蓝天630902

网页翻页：

3、可以调用js函数翻页，比如：

Sub 价格查询2()
    On Error Resume Next
    With CreateObject("internetexplorer.application")
        .Visible = True
        .Navigate "http://www.dq123.com/price/priceindex.aspx"
        Do Until .ReadyState = 4
            DoEvents
        Loop
        For p = 0 To 36640
        .Navigate "javascript:gopage(" & p & ")"  '调用js函数翻页
        Do Until .ReadyState = 4
            DoEvents
        Loop
            Set r = .Document.All.tags("table")(7).Rows
            n = Range("a65536").End(xlUp).Row
            For i = 0 To r.Length - 1
                For j = 0 To r(i).Cells.Length - 1
                If j > 0 And j < 3 Then
                    Cells(i + n + 1, j + 1) = r(i).Cells(j).Title
                Else
                    Cells(i + n + 1, j + 1) = r(i).Cells(j).innerText
                End If
                Next j
            Next i
        Next p
    End With
End Sub