vba开发实例教程

上面为vba要处理的excel页面展示；

2、

如下是处理的脚本

'主方法
Sub main_function()

Dim MyUrl As String

MyUrl = Range("B7").Value
MyUrl = "http://" & MyUrl & ":8080/Citics/switch.jsp?userName=" & Range("b5").Text & "&password=" + Range("b6").Text

'Get the HTML of the URL
Set IE = CreateObject("InternetExplorer.Application")

IE.navigate MyUrl

While IE.Busy
DoEvents
Wend

With ActiveSheet.UsedRange
    iEndRowT = .Rows.Count + .Row - 1
    iEndColumnT = .Columns.Count + .Column - 1
End With
If iEndRowT > 10 Then
    '遍历
    result = for_url(iEndRowT, IE)

    MsgBox "执行完成"
Else
    MsgBox "没有要操作的数据，正常退出"
End If

End Sub

Function for_url(ByVal iEndRowT, ByVal IE) As Integer
Application.ScreenUpdating = False '禁止刷新
For startrow = 11 To iEndRowT
     'excel名称
     Dim workname As String
     'sheet名称
     Dim sheetname As String
     workname = ActiveSheet.Range("B" & startrow).Value
     sheetname = ActiveSheet.Range("C" & startrow).Value
     If workname <> "" Then
        '文件路径
         Dim path As String
         path = ThisWorkbook.path & "\" & workname

         Dim Sht As Worksheet
         Set Sht = workbooks.Open(path).Sheets(sheetname)

         With ActiveWorkbook.Worksheets(sheetname).UsedRange
                 iEndRow = .Rows.Count + .Row - 1
                 iEndColumn = .Columns.Count + .Column - 1
         End With

         If iEndRow > 1 Then
                 iEndRow = iEndRow + 1
         End If
         '获取url
         Dim strurla As String
         strurla = ActiveSheet.Range("A" & startrow).Value
         strurla = Replace(strurla, "beginDate", "endDate2")
         strurla = Replace(strurla, "endDate", "endDate2")

          '获取开始日期
         recdateStart = ActiveSheet.Range("B8").Value
         strurla = strurla & "&beginDate=" & recdateStart & "&endDate=" & recdateStart
         'MsgBox strurla
         IE.navigate strurla
         While IE.Busy
         DoEvents
         Wend

         irow = iEndRow '从哪行开始显示
         '表格中插入数据
         result = insert(irow, IE, startrow, Sht)

         ActiveWorkbook.Save
     Else
        MsgBox "在" & startrow & "行是空行，请删除空行或者是有空格，请您补全空格，出问题的这一行将会跳过执行!"
     End If
Next startrow
Application.ScreenUpdating = True '恢复刷新

End Function

'表格中插入数据
Function insert(ByVal irow, ByVal IE, ByVal startrow, ByVal Sht) As Integer

icol = 0

Dim ilength As Integer
ilength = IE.document.all.tags("td").Length

    Dim MyArray() As String

    ReDim MyArray(ilength + 1)

    k = 1
    For Each d In IE.document.all.tags("td")
        MyArray(k) = d.innerText
        k = k + 1
    Next

    Dim tr_length As Integer
    '插入的条数
    tr_length = IE.document.all.tags("tr").Length

    If tr_length = 2 Then
        tr_length = tr_length - 2
    End If

    '当条数只有一条的是很说明只有标题，不进行excel的插入，退出本次循环
    If tr_length <= 0 Then
        ActiveSheet.Range("D" & startrow).Value = 0
    Else
        ActiveSheet.Range("D" & startrow).Value = tr_length - 2
        tr_length = tr_length - 1 '去掉第一个tr
        For Each r In IE.document.all.tags("tr")

        cellcol = 1 '从那列开始显示
        Dim td_length As Integer
        td_length = IE.document.all.tags("td").Length - 2
        Dim next_row As Integer
        next_row = td_length / tr_length
        For coloop = 3 + icol To td_length + 2
            icol = icol + 1
            If icol > next_row Then '去掉标题，标题不往excel中写
                Sht.Cells(irow, cellcol) = MyArray(coloop)
                cellcol = cellcol + 1
                If (icol Mod (next_row) = 0) Then Exit For
            End If
         Next coloop

         irow = irow + 1

        Next
    End If

End Function

猜你喜欢