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