Question

我试图通过提供一些输入参数从内部网站提取表格。一切正常，直到用我的输入刷新网站数据。我得到运行时错误438的部分被标记为（For r = 1 To elemCollection.Rows.Length - 1）。我还尝试使用网页查询将网站上的数据加载到excel，并且表格没有显示在我的Excel电子表格中。＆＃34;它出现以下错误 - 此页面可能无法正常运行，因为您的浏览器不支持脚本或禁用活动脚本。您的浏览器不支持脚本或已配置为不允许脚本。报表查看器Web控件http处理程序尚未在应用程序的Web配置文件中注册。＆＃34;

想知道这是否与权限有关。

以下VBA代码：

Option Explicit
Sub Macro1()

  Dim IE As Object, obj As Object
  Dim StartDate As Object
  Dim EndDate As Object
  Dim myState As String
  Dim r As Integer, c As Integer, t As Integer
  Dim elemCollection As Object, curHTMLRow As Object
  Dim wb As Workbook
  Dim ws As Worksheet
  Dim objCollection As Object
  Dim objElement As Object
  Dim i As Long

  Set IE = CreateObject("InternetExplorer.Application")

  IE.Visible = True

  IE.navigate ("http://internalwebsite_SSRSReport")

  ' we ensure that the web page downloads completely before we fill the form automatically
  While IE.ReadyState <> 4: DoEvents: Wend

  IE.Document.All.Item("ctl31_ctl03_txtValue").InnerText = Format("7/1/2016", "m/d/yyyy")
  IE.Document.All.Item("ctl31_ctl05_txtValue").InnerText = Format("7/31/2016", "m/d/yyyy")

  Wait 2

  IE.Document.getElementsByName("ctl31_ctl04_divDropDown").Item.Click

  Wait 2

  ' accessing the button
  IE.Document.getElementsByName("ctl31_ctl04_ctl00").Item.Click
  Wait 2
  ' again ensuring that the web page loads completely before we start scraping data
  While IE.busy: DoEvents: Wend

      Wait 2

     'Clearing any unnecessary or old data in Sheet1
      ThisWorkbook.Sheets("Sheet1").Activate
      Range("A1:K500").ClearContents

      Set elemCollection =  IE.Document.getelementbyId("ctl31_ctl09_ReportArea")

      'error here
      For r = 1 To elemCollection.Rows.Length - 1

      Set curHTMLRow = elemCollection.Rows(r)
      For c = 0 To curHTMLRow.Cells.Length - 1
          Cells(r + 1, c + 1) = curHTMLRow.Cells(c).InnerText
      Next
  Next

  ' cleaning up memory
  IE.Quit
  Set IE = Nothing

End Sub
Private Sub Wait(ByVal nSec As Long)
    nSec = nSec + Timer
    While nSec > Timer
        DoEvents
    Wend
End Sub

Answer 1

下面是一些代码，它们应该能够从SSRS报告中获取HTML表中的数据并将其解压缩到Excel。

基本上，代码将迭代表元素中的所有TR和TD，并将InnerText输出到Excel。如果要移动很多数据，请考虑写入数组，然后通过设置为同等大小的范围对象来一次写入。

我还清理了代码，主要是删除未引用的变量，并通过将一些语句组合在一起来减少一些行

Option Explicit

Public Sub GetSSRSData()
    On Error GoTo errhand:
    Application.ScreenUpdating = False
    Dim IE            As Object: Set IE = CreateObject("InternetExplorer.Application")
    Dim TR_Elements   As Object
    Dim TR            As Object ' Table Row
    Dim TD_Elements   As Object
    Dim TD            As Object ' Table Data
    Dim RowNumb       As Integer
    Dim Columns       As Integer
    Dim ColumnNumb    As Integer

    With IE
        .Visible = True
        .Navigate ("http://internalwebsite_SSRSReport")

        While .ReadyState <> 4: DoEvents: Wend ' Wait for page load
        'Fill the form out with dates
        .Document.All.Item("ctl31_ctl03_txtValue").InnerText = Format("7/1/2016", "m/d/yyyy")
        .Document.All.Item("ctl31_ctl05_txtValue").InnerText = Format("7/31/2016", "m/d/yyyy")
        Wait 2

        'Click the DropDown
        .Document.getElementsByName("ctl31_ctl04_divDropDown").Item.Click
        Wait 2

        ' Click the other button
        .Document.getElementsByName("ctl31_ctl04_ctl00").Item.Click
    End With

    Wait 2
    While IE.busy: DoEvents: Wend ' Wait for page load
    Wait 2

    'Clearing any unnecessary or old data in Sheet1
    Sheets("Sheet1").Range("A1:K500").ClearContents
    Set TR_Elements = IE.Document.getelementbyId("ctl31_ctl09_ReportArea").getElementsByTagName("tr")
    RowNumb = 1
    ColumnNumb = 1
    'Tables usually consists of TR (Table Rows), and -
    'TD (Table Data)
    For Each TR In TR_Elements
        Set TD_Elements = TR.getElementsByTagName("td")
        ColumnNumb = 1
        For Each TD In TD_Elements
            'Consider using an array to save the values to memory if there is going
            'to be a lot of data to be moved over
            ActiveSheet.Cells(RowNumb, ColumnNumb).Value = TD.InnerText
            ColumnNumb = ColumnNumb + 1
        Next
        RowNumb = RowNumb + 1
    Next

    ' cleaning up memory
    IE.Quit
    Set IE = Nothing
    Set TD_Elements = Nothing
    Set TR_Elements = Nothing
    Set TD = Nothing
    Set TR = Nothing
    Application.ScreenUpdating = True

errhand:
     Application.ScreenUpdating = True
End Sub

Private Sub Wait(ByVal nSec As Long)
    nSec = nSec + Timer
    While nSec > Timer
        DoEvents
    Wend
End Sub

Excel VBA运行时错误438.对象不支持此属性或方法。当试图将网站表复制到excel时

1 个答案: