0

我正在构建一个模型，该模型尝试使用全选> 复制从不同网站的网络中提取数据。下面是我拥有的代码，它似乎在某些区域以中断模式工作，而在其他区域它仅在我运行宏时才有效。

当时让我感到困惑的部分是当它命中： "ActiveSheet.PasteSpecial Format:="Text", link:=False, DisplayAsIcon:=False" 时，它失败并给我 Error 1004 "PasteSpecial method of Worksheet class failed 。”

在调试后按 F8 时，代码继续运行良好（尽管在向我显示“无法在中断模式下执行代码 3 次之后）。我尝试更改代码以显示“工作表（“GOOGLE”）”和其他方法直接定义工作表。我的直觉是这可能不是问题。如果是这样，我不知道这里发生了什么！有人可以测试一下吗？

仅供参考，我还在此代码之上使用用户表单（无模式）作为“等待”消息，因为运行时间可能会很长。不确定这是否会干扰粘贴。

Dim IE As Object
Dim PauseTime, Start
PauseTime = 22 ' Set duration in seconds
Start = Timer ' Set start time.

Application.ScreenUpdating = False

Worksheets("GOOGLE").Activate
Worksheets("GOOGLE").Cells.Clear
Worksheets("GOOGLE").Range("A1").Copy
Application.CutCopyMode = False


    Set IE = CreateObject("InternetExplorer.Application")
    With IE
        .Navigate Range("GOOGLEURL").Value
        Do Until .ReadyState = 4: DoEvents: Loop
        End With

        Do While Timer < Start + PauseTime
        DoEvents
        Loop

        IE.ExecWB 17, 0 '// SelectAll
        IE.ExecWB 12, 2 '// Copy selection
        ActiveSheet.Range("A1").Select
        ActiveSheet.PasteSpecial Format:="Text", link:=False, DisplayAsIcon:=False
        IE.Quit


    On Error GoTo Ending
        IE.Quit 
        Application.CutCopyMode = False

Ending:
Application.CutCopyMode = False
Exit Sub
4

4 回答 4

2

试试这个方法，而不是在应用程序之间复制/粘贴。像你一样，我试过了，发现它不可靠，而且经常不起作用。

您可以在字符串中抓取页面innerText并使用它，或者，您可以将其拆分innerText为一个数组并将其放在工作表上，就像我在我的示例中所做的那样。这保留了换行符并使其比将所有文本放在单个单元格中更具可读性

我在一个简单的示例 ( http://google.com ) 上验证了这一点，这两种方法都返回了工作表中完全相同的单元格布局。

注意：当您在 IE 中安装了 ChromeFrameBHO 插件时，此方法可能不起作用（请参阅此处）。

Sub Test()
Dim IE As Object
Dim pageText As String
Dim page As Variant

Set IE = CreateObject("InternetExplorer.Application")
    With IE
        .Navigate "http://google.com"
        Do Until .ReadyState = 4: DoEvents: Loop
    End With

    pageText = IE.Document.body.innertext
    page = Split(pageText, vbCr)

    Range("A1").Resize(UBound(page)).Value = Application.Transpose(page)

    IE.Quit
    Set IE = Nothing

End Sub

不依赖 Internet Explorer 的另一种方法是QueryTables方法。它可能适合也可能不适合您的需求，但请尝试这样的事情。

注意：无论是否安装了 ChromeFrameBHO 插件，此方法似乎都有效（对我而言）。

Sub TestQueryTables()

    Dim googleURL as String
    googleURL = Range("GOOGLEURL")

    With ActiveSheet.QueryTables.Add(Connection:= _
            "URL;" & googleURL _
            , Destination:=Range("A1"))
            .Name = googleURL
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = True
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .WebSelectionType = xlEntirePage
            .WebFormatting = xlWebFormattingNone 'or use xlWebFormattingAll to preserve formats
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = False
            .WebDisableRedirections = False
            .Refresh BackgroundQuery:=False
        End With

End Sub
于 2013-09-06T02:02:55.607 回答
1

实际上，我一直在通过复制和粘贴一堆图像来解决这个完全相同的问题。Excel 2010 显然存在在复制命令完成之前尝试粘贴的问题。您可以做的是结合睡眠事件和错误处理特定的 1004 错误。设置错误处理程序以捕获 1004 错误，然后让它恢复。我所做的是设置一个这样的计数器：

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
On Error GoTo ErrorHandler:
Dim err_counter As Integer

ErrorHandler:

If Err.Number = 1004 Then
    err_counter = err_counter + 1

    If err_counter > 10 Then
        MsgBox ("The copy function is taking too long. Consider using smaller images.")
        Exit Sub
    End If

    DoEvents
    Sleep 500
    DoEvents
ElseIf Err.Number <> 0 Then
    MsgBox ("Unknown error.")
    On Error GoTo 0
    Resume
End If

您不需要使用错误计数器，但我认为防止我的电子表格的未来用户以某种方式创建无限循环是个好主意。我还会在每次粘贴图像后清除剪贴板，如果您使用错误计数器，请在粘贴成功后将其重置为 0。

于 2014-02-26T16:00:02.390 回答
0

我无法验证我的回复，但大约一年前我遇到了类似的问题。有问题的网页必须使用复制/粘贴而不是使用内文。看来您已经完成了我所做的大部分工作，包括暂停等待或完成复制。（Readystate 对我没有帮助。）

我记得做的最后一件事是让代码工作，就是将粘贴放在一个有限循环中。粘贴通常在第三次和第八次尝试之间成功。

我确信有更好的方法，但找不到。由于我的应用程序是供我自己使用的，因此代码是可以接受的。由于网页每隔几个月就会更改一次，因此代码被放弃了。

于 2013-09-12T02:38:32.513 回答
0

看起来您正在复制，但您在粘贴之前清除了剪贴板，因此没有任何内容可供代码粘贴。

Worksheets("GOOGLE").Range("A1").Copy
Application.CutCopyMode = False

另外，您是从 Sheets("Google").Range("A1") 复制到 Sheets("Google").Range("A1") 吗？我不明白

于 2013-09-05T20:39:01.637 回答