上面為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