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