从Word粘贴到Excel时，Word VBA宏有时会锁定

如何解决从Word粘贴到Excel时，Word VBA宏有时会锁定

我是一个外行人士，他试图编写一个宏以将信息从.doc复制到.xlsx文件。宏在大多数情况下都起作用，但是在Word打开Excel的某个时候，它实际上无法将信息粘贴到文件中。

我有一个运行的测试.doc有时可以运行30次，但是它们似乎随机失败，没有错误消息。它将打开我的.xlsx模板，但实际上没有粘贴到其中。然后，我必须使用任务管理器杀死Word应用程序，并且除非我完全重新启动PC，否则宏将无法再次运行。我已经关闭了Excel中的“启用实时预览”功能，这似乎有所帮助，但不能完全解决此问题。

''''
Sub Master_Create_Cut_Packet()
'
'
'
' V2 No longer uses Order Number: to locate header tables for deletion.
'
'
'
' Start search for Install and read in the next two tables and the circuit IDs associated.
' Then compare the two ckt IDs and if they match compare the two tables for matching field and mark column S as Reuse in the pending design if they match.
' Then if Column 9 is blank populate it with NEW_Seq*_
'
'


Dim y As Integer



'Start Check to ensure there are 29 or less circuits in the Circuit.doc file"
    StatusBar = "Counting the number of Install paths."
    Selection.HomeKey Unit:=wdStory      'return to top of doc
    Selection.Find.ClearFormatting
    With ActiveDocument.Content.Find
        do while .Execute(FindText:="Circuit Id: ",Forward:=True,Format:=True,_
           MatchWholeWord:=True) = True
           y = y + 1
        Loop
    End With
    
    If y > 58 Then
    MsgBox "Circuits.doc has more than 29 circuits in it. This script will only run for a maximun of 29 circuits. Please reduce the number of circuits and rerun the script."
    Exit Sub
    Else
    End If
'End Check to ensure there are 29 or less circuits in the Circuit.doc file"



MsgBox "Please ensure that you do not have the excel file 'Template.xlsx' open. If you do please close it before clicking OK or you may have to restart your PC."



' Start separate_CKT_ID_from_Design_Type Macro
    Selection.HomeKey Unit:=wdStory      'return to top od doc
    StatusBar = "Word is adding a space between the Circuit IDs and (Install) or (Pending)."
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "(Install)"
        .Replacement.Text = " (Install)"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "(Pending)"
        .Replacement.Text = " (Pending)"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
' End separate_CKT_ID_from_Design_Type Macro



' Start search for Install and read in the next two tables and the circuit IDs associated.
' Then compare the two ckt IDs and if they match compare the two tables for matching field and mark column S as Reuse in the pending design if they match.
' Then if Column 9 is blank populate it with NEW_Seq*_

    Dim tbl1 As Table
    Dim tbl2 As Table
    Dim r As Integer
    Dim rr As Integer
    Dim c As Integer
    Dim i As Range
    Dim P As Range

    
    Set tbl1 = ActiveDocument.Tables(1)
    Set tbl2 = ActiveDocument.Tables(2)
    
    StatusBar = "Word is comparing the Install and Pending designs and marking the reuse ports in the S column with 'REUSE_Seq*_'"
    Selection.HomeKey Unit:=wdStory      'return to top of doc
    With Selection.Find
        .Text = "(Install)"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
        do while Selection.Find.Execute = True
            Selection.MoveLeft Unit:=wdWord,Count:=2
            Selection.MoveRight Unit:=wdWord,Count:=1,Extend:=wdExtend
            Set i = ActiveDocument.Range(Selection.Range.Start,Selection.Range.End)
     
            Selection.GoTo What:=wdGoToTable,Which:=wdGoToNext,Count:=2,Name:=""
            Selection.Tables(1).Select
            
            Selection.MoveRight Unit:=wdWord,Count:=4
            Selection.MoveRight Unit:=wdWord,Extend:=wdExtend
            Set P = ActiveDocument.Range(Selection.Range.Start,Selection.Range.End)
            Selection.GoTo What:=wdGoToTable,Name:=""
            Selection.Tables(1).Select
            
                If i = P Then
                    
                    Else: MsgBox "ALERT: Did not find both a Install and Pending design for: " & i
                          MsgBox "Due to each circuit not having a Install and Pending design this Macro will Now stop,please reselect circuits and try again."
                          Selection.GoTo What:=wdGoToTable,Which:=wdGoToPrevIoUs,Name:=""
                          Exit Sub
                End If
        Loop

    Set tbl1 = nothing
    Set tbl2 = nothing
' End compare the two ckt IDs and if they match compare the two tables for matching field and mark column S as Reuse in the pending design if they match.



' Start Delete all of the header tables
    StatusBar = "Word is deleting header tables that follows each Circuit ID"
    Selection.HomeKey Unit:=wdStory      'return to top od doc
        Selection.Find.ClearFormatting
        With Selection.Find
            .Text = "(Install)"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
            do while Selection.Find.Execute = True
                Selection.GoTo What:=wdGoToTable,Name:=""
                Selection.Tables(1).Select
                Selection.Tables(1).Delete
                Selection.Delete Unit:=wdCharacter,Count:=1
            Loop
                Selection.HomeKey Unit:=wdStory      'return to top od doc
        Selection.Find.ClearFormatting
        With Selection.Find
            .Text = "(Pending)"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
            do while Selection.Find.Execute = True
                Selection.GoTo What:=wdGoToTable,Count:=1
            Loop
    ' End Delete all fo the header tables



' Start find all of the Install Designs and populate empty cells in S column with REUSE_Seq*_
    StatusBar = "Word is finding all of the Install designs and populating the empty cells in S column with 'REUSE_Seq*_'"
    Dim tTable As Table
    Dim cCell As Cell
    Dim stemp1 As String
    Dim stemp2 As String
    Dim stemp3 As String
    
    stemp1 = "REMOVE_Seq*_"
    stemp2 = "REUSE_Seq*_"
    stemp3 = "NEW_Seq*_"
    
    Selection.HomeKey Unit:=wdStory      'return to top of doc
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "(Install)"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    do while Selection.Find.Execute = True
    Selection.GoTo What:=wdGoToTable,Name:=""
    Selection.Tables(1).Select
        If Selection.information(wdWithInTable) Then
            Set tTable = Selection.Tables(1)
            For Each cCell In tTable.Range.Columns(9).Cells
                If (cCell.Range.Text) = "OUT" & Chr(13) & Chr(7) Then
                    cCell.Range = stemp1
                ElseIf (cCell.Range.Text) = Chr(13) & Chr(7) Then
                    cCell.Range = stemp2
                End If
            Next
        End If
    Set oCell = nothing
    Set tTable = nothing
    Loop
' End   find all of the Install Designs and populate empty cells in S column with REUSE_Seq*_



' Start search for Install and read in the next two tables and the circuit IDs associated.
' Then compare the two ckt IDs and if they match compare the two tables for matching field and mark column S as Reuse in the pending design if they match.
' Then if Column 9 is blank populate it with NEW_Seq*_

    
    Set tbl1 = ActiveDocument.Tables(1)
    Set tbl2 = ActiveDocument.Tables(2)
    
    StatusBar = "Word is comparing the Install and Pending designs and marking the reuse ports in the S column with 'REUSE_Seq*_'"
    Selection.HomeKey Unit:=wdStory      'return to top of doc
    With Selection.Find
        .Text = "(Install)"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
   End With
        do while Selection.Find.Execute = True
            Selection.MoveLeft Unit:=wdWord,Name:=""
            Selection.Tables(1).Select
            Set tbl1 = Selection.Tables(1)
            
            Selection.MoveRight Unit:=wdWord,Count:=4
           Selection.MoveRight Unit:=wdWord,Name:=""
            Selection.Tables(1).Select
            Set tbl2 = Selection.Tables(1)
            
                If i = P Then
                    
                    Else: MsgBox "ALERT: Did not find both a Install and Pending design for: " & i
                          MsgBox "Due to each circuit not having a Install and Pending design this Macro will Now stop,Name:=""
                          Exit Sub
                End If

            
            c = 7 'Which Column to search 1
            For r = 2 To tbl1.Rows.Count
            For rr = 2 To tbl2.Rows.Count
                ' start check site,then object,then additional detail all match
                If tbl1.Cell(r,1).Range.Text = tbl2.Cell(rr,1).Range.Text Then
                    If tbl1.Cell(r,4).Range.Text = tbl2.Cell(rr,4).Range.Text Then
                        If tbl1.Cell(r,c).Range.Text = tbl2.Cell(rr,c).Range.Text Then
                        tbl2.Cell(rr,9).Range.Text = stemp2
                        End If
                    End If
                End If
                ' end check
                If tbl2.Cell(rr,9).Range.Text = Chr(13) & Chr(7) Then
                    tbl2.Cell(rr,9).Range.Text = stemp3
                End If
            Next rr
            Next r
        Loop

    Set tbl1 = nothing
    Set tbl2 = nothing
' End compare the two ckt IDs and if they match compare the two tables for matching field and mark column S as Reuse in the pending design if they match.




'*******************************************************************************************************************
'
'
' This will copy all the circuit designs from the Master CLR Markup into an excel template to create a cut packet.
'
'
'
Dim oXL   As Excel.Application
Dim oWB   As Excel.Workbook
Dim tbl As Table
Dim LastRow As Long,LastColumn As Integer
Dim tblRange As Range
Dim wksht As Integer
Dim ii As Integer
Dim x,Response,ExitResponse
Dim Check,Counter
Check = True: Counter = 0    ' Initialize variables.

y = 0
wrsht = 2
Check = True: Counter = 0    ' Initialize variables.



'Start If Excel is running,get a handle on it; otherwise start a new instance of Excel
    StatusBar = "Checking to see if Excel application is open,and if not opening it."

    On Error Resume Next
    Set oXL = Getobject(,"Excel.Application")
    If Err Then
        Set oXL = CreateObject("Excel.Application")
    End If
    On Error GoTo 0
        Set oWB = oXL.Workbooks.Open(FileName:="C:\Temp\Template.xlsx")
        oXL.Visible = True
lbl_Exit:
'End If Excel is running,get a handle on it; otherwise start a new instance of Excel




'Start Search for and count occurrences of the text typed.
    StatusBar = "Counting the number of Install paths."
    Selection.HomeKey Unit:=wdStory      'return to top of doc
    Selection.Find.ClearFormatting
    x = "(Install)"
    With ActiveDocument.Content.Find
        do while .Execute(FindText:=x,_
           MatchWholeWord:=True) = True
           y = y + 1
        Loop
    End With
'End Search for and count occurrences of the text typed.
    

    
'Start Run an Outer and Inner Loop to step through the word doc and copy out the information
    Selection.HomeKey Unit:=wdStory      'return to top of doc
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "(Install)"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    
    
    
        Do    ' Outer loop.
                   ' display message in Word's Status Bar.
                    StatusBar = "Word is moving circuits into Excel Cut Packet"

            If Counter = y Then    ' If condition is True.
                Check = False    ' Set value of flag to False.
                Exit Do    ' Exit inner loop.
            End If
            
            do while Counter < y    ' Inner loop.
                With Selection
                 .Collapse 'Collapse current selection to an insertion point
                 .Expand Unit:=wdSentence  'Expand selection to current sentence.
                End With
            Selection.Cut
            On Error GoTo errorHandler ' Enable error-handling routine.
                oXL.ActiveWorkbook.Worksheets(wrsht).Paste Destination:=ActiveWorkbook.Worksheets(wrsht).Range("A7")
                Selection.GoTo What:=wdGoToTable,Name:=""
                Selection.Tables(1).Select
                    Set tbl = Selection.Tables(1)
                        With tbl
                        LastRow = .Rows.Count
                        LastColumn = .Columns.Count
                        Set tblRange = .Cell(1,1).Range
                        tblRange.End = .Cell(LastRow,LastColumn).Range.End
                        tblRange.Cut
                    End With
                For ii = 1 To 200
                Next ii
            On Error GoTo errorHandler ' Enable error-handling routine.
                oXL.ActiveWorkbook.Worksheets(wrsht).Paste Destination:=ActiveWorkbook.Worksheets(wrsht).Range("A8")
                Selection.MoveRight Unit:=wdWord,Count:=1
                    With Selection
                        .Collapse 'Collapse current selection to an insertion point
                        .Expand Unit:=wdSentence  'Expand selection to current sentence.
                    End With
                Selection.Cut
             On Error GoTo errorHandler ' Enable error-handling routine.
                oXL.ActiveWorkbook.Worksheets(wrsht).Paste Destination:=ActiveWorkbook.Worksheets(wrsht).Range("K7")
                Selection.GoTo What:=wdGoToTable,Name:=""
                Selection.Tables(1).Select
                    Set tbl = Selection.Tables(1)
                    With tbl
                        LastRow = .Rows.Count
                        LastColumn = .Columns.Count
                        Set tblRange = .Cell(1,LastColumn).Range.End
                        tblRange.Cut
                    End With
             On Error GoTo errorHandler ' Enable error-handling routine.
                oXL.ActiveWorkbook.Worksheets(wrsht).Paste Destination:=ActiveWorkbook.Worksheets(wrsht).Range("K8")
                On Error Resume Next
                Selection.MoveRight Unit:=wdWord,Count:=1
                wrsht = wrsht + 1
        
            Counter = Counter + 1    ' Increment Counter.
                If Counter = y Then    ' If condition is True.
                Check = False    ' Set value of flag to False.
            Exit Do    ' Exit inner loop.
            End If
            Loop
        Loop Until Check = False    ' Exit outer loop immediately.
'End Run an Outer and Inner Loop to step through the word doc and copy out the information



'Start Close the Circuit.doc export file
    On Error GoTo WordErrorHandler
    ActiveDocument.Close _
     SaveChanges:=wdDoNotSaveChanges
     Application.WindowState = wdWindowStateMinimize
     
WordErrorHandler:
        If Err = 4198 Then MsgBox "Circuit.doc Failed to close."
'End Close the Circuit.doc export file



'Start Release all declared objects
    Set oWB = nothing
    Set oXL = nothing
'End Release all declared objects



'Start Release all declared objects
    Set oWB = nothing
    Set oXL = nothing
'End Release all declared objects



'Start Exit the main program,everything below this is subroutines
    Exit Sub
'End Exit the main program,everything below this is subroutines



'Start Error handler for copying and pasting
errorHandler:
'    Wait 0.5
For ii = 1 To 1000
Next ii
    Resume
    Exit Sub
'End Error handler for copying and pasting



'Start Error handler for opening Excel application and workbook
Err_Handler:
    MsgBox WorkbookToWorkOn & " caused a problem. " & Err.Description,vbCritical,_
           "Error: " & Err.Number
    If ExcelWasNotRunning Then
        oXL.Quit
    End If
'End Error handler for opening Excel application and workbook



End Sub



Sub Master_copy_To_Excel_V2()
'
'
' This will copy all the circuit designs from the Master CLR Markup into an excel template to create a cut packet.
'
'
'
Dim oXL   As Excel.Application
Dim oWB   As Excel.Workbook
Dim ExcelWasNotRunning   As Boolean
Dim tbl As Table
Dim LastRow As Long,LastColumn As Integer
Dim tblRange As Range
Dim wksht As Integer
Dim y As Integer
Dim Check,Counter
Dim i As Integer



wrsht = 2
Check = True: Counter = 0    ' Initialize variables.


'MsgBox "Please ensure you do not have the excel file Template.xlsx open.


'Start If Excel is running,"Excel.Application")
    If Err Then
        Set oXL = CreateObject("Excel.Application")
    End If
    On Error GoTo 0
    Set oWB = oXL.Workbooks.Open(FileName:="C:\Temp\Template.xlsx")
    oXL.Visible = True
lbl_Exit:
'End If Excel is running,get a handle on it; otherwise start a new instance of Excel



'Start Search for and count occurrences of the text typed.
    StatusBar = "Counting the number of Install paths."
    Selection.HomeKey Unit:=wdStory      'return to top of doc
    Selection.Find.ClearFormatting
    x = "(Install)"
    With ActiveDocument.Content.Find
        do while .Execute(FindText:=x,LastColumn).Range.End
                        tblRange.copy
                    End With
            On Error GoTo errorHandler ' Enable error-handling routine.
                oXL.ActiveWorkbook.Worksheets(wrsht).Paste Destination:=ActiveWorkbook.Worksheets(wrsht).Range("A8")
                Selection.MoveRight Unit:=wdWord,LastColumn).Range.End
                        tblRange.copy
                    End With
             On Error GoTo errorHandler ' Enable error-handling routine.
                oXL.ActiveWorkbook.Worksheets(wrsht).Paste Destination:=ActiveWorkbook.Worksheets(wrsht).Range("K8")
                Selection.MoveRight Unit:=wdWord,everything below this is subroutines



'Start Error handler for copying and pasting
errorHandler:
'    Wait 0.5
For i = 1 To 1000
Next i
    Resume
    Exit Sub
'End Error handler for copying and pasting



'Start Error handler for opening Excel application and workbook
Err_Handler:
    MsgBox WorkbookToWorkOn & " caused a problem. " & Err.Description,_
           "Error: " & Err.Number
    If ExcelWasNotRunning Then
        oXL.Quit
    End If
'End Error handler for opening Excel application and workbook



End Sub
''''

有人可以给我一些检查内容的想法吗？

解决方法

如果您的复制/粘贴问题不是时间问题（无法通过等待和重试解决），那么此错误处理程序将使您陷入无尽的困境错误等待重试循环：

'Start Error handler for copying and pasting
errorHandler:
'    Wait 0.5
For ii = 1 To 1000
Next ii
    Resume
    Exit Sub

最好记录一次您重试的次数，然后在达到一定值（例如5或10次尝试）后退出该尝试。