Question

提供代码功能的快照：

用户点击按钮导入作业文件夹
文件路径选择打开，用户选择文件
VBA从作业文件和粘贴中导入指定的单元格值链接到工作表。

一切正常，除了偶尔我得到一个错误，上面写着“没有链接粘贴”并引用ActiveSheet.Paste Link:=True行，但如果我按下VBA代码编辑器上的runsub按钮就可以了。我不知道为什么我有时会得到这个错误。有没有办法让代码重新运行该错误？

错误发生在下面显示的代码中的任何ActiveSheet.Paste Link:=True，同样是随机和任何导入选择（项目名称或客户名称或项目名称等）

'Imports Project#
sourcewb.Sheets("Estimate").Range("PROJECT_NUMBER").Copy       'project# info is located on "Reporting" tab
summarywb.ActiveSheet.Activate
summarywb.ActiveSheet.Cells(NewRow, 1).Select
ActiveSheet.Paste Link:=True


'Imports Client Name
sourcewb.Sheets("Estimate").Range("PROJECT_CLIENT").Copy       'C3 is where client name info is located on "Reporting"
summarywb.ActiveSheet.Activate
summarywb.ActiveSheet.Cells(NewRow, 2).Select
ActiveSheet.Paste Link:=True


'Imports Project Name
sourcewb.Sheets("Estimate").Range("PROJECT_NAME").Copy       'C2 is where project name info is located on "Reporting"
summarywb.ActiveSheet.Activate
summarywb.ActiveSheet.Cells(NewRow, 3).Select
ActiveSheet.Paste Link:=True


'Imports Latest Revision Date
sourcewb.Sheets("Reporting").Range("O5").Copy               'P5 is where project name info is located on "Reporting"
summarywb.ActiveSheet.Activate
summarywb.ActiveSheet.Cells(NewRow, 19).Select
ActiveSheet.Paste Link:=True
0

'Imports data from Project Total line
sourcewb.Sheets("Reporting").Range("C24:Q24").Copy       'Row 24 is where Project Total line is located on "Reporting"

PTRange = "D" & NewRow & ":" & "R" & NewRow

summarywb.ActiveSheet.Activate
summarywb.ActiveSheet.Range(PTRange).Select
ActiveSheet.Paste Link:=True

以下是完整代码：

    '///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'
'This code imports select data from specified project's cost tracking spread sheet.
'
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Sub ImportProjectStatus()

'Minimize runtime
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'Initialize Variables
Dim summarywb As Workbook
Dim sourcewb As Workbook
Dim currentVer As String

Dim FirstRow As Long
Dim LastRow As Long
Dim NewRow As Long

Dim NewJobNumber As String
Dim PTRange As String

'Set initial values
Set summarywb = ThisWorkbook
currentVer = "0.8.0"


'Open file selection dialog box
Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
openFile = Application.FileDialog(msoFileDialogOpen).Show
If openFile <> 0 Then
    sourcewbpath = Application.FileDialog(msoFileDialogOpen).SelectedItems(1)           'Select the corresponding master file
Else
    sourcewbpath = ""
    Exit Sub
End If

Set sourcewb = Workbooks.Open(sourcewbpath)

'Error Handling - If there is no reporting tab on a tracking sheet
On Error GoTo NoReportTabError

'Searches for first non-blank row with data
FirstRow = summarywb.ActiveSheet.Cells.Find(What:="Project #", After:=Range("A1"), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row + 1

'Searches for last non-blank row
LastRow = summarywb.ActiveSheet.Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row

'Sets Row to which new data will be imported
NewRow = LastRow + 1

'Checks if to-be imported job number is a duplicate
NewJobNumber = sourcewb.Sheets("Reporting").Range("P2")

If DuplicateCheck(summarywb, FirstRow, LastRow, NewRow, NewJobNumber) = 1 Then
    If MsgBox(NewJobNumber & " already exists. Continue?", vbYesNo, "Confirm") = vbNo Then
        'Close sourcewb
        sourcewb.Close savechanges:=False
        'Display back on
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        'Abort message
        MsgBox "Job not added."
        Exit Sub
    End If
End If

'Imports Project#
sourcewb.Sheets("Estimate").Range("PROJECT_NUMBER").Copy       'project# info is located on "Reporting" tab
summarywb.ActiveSheet.Activate
summarywb.ActiveSheet.Cells(NewRow, 1).Select
ActiveSheet.Paste Link:=True

'Imports Client Name
sourcewb.Sheets("Estimate").Range("PROJECT_CLIENT").Copy       'C3 is where client name info is located on "Reporting"
summarywb.ActiveSheet.Activate
summarywb.ActiveSheet.Cells(NewRow, 2).Select
ActiveSheet.Paste Link:=True

'Imports Project Name
sourcewb.Sheets("Estimate").Range("PROJECT_NAME").Copy       'C2 is where project name info is located on "Reporting"
summarywb.ActiveSheet.Activate
summarywb.ActiveSheet.Cells(NewRow, 3).Select
ActiveSheet.Paste Link:=True

'Imports Latest Revision Date
sourcewb.Sheets("Reporting").Range("O5").Copy               'P5 is where project name info is located on "Reporting"
summarywb.ActiveSheet.Activate
summarywb.ActiveSheet.Cells(NewRow, 19).Select
ActiveSheet.Paste Link:=True

'Imports data from Project Total line
sourcewb.Sheets("Reporting").Range("C24:Q24").Copy       'Row 24 is where Project Total line is located on "Reporting"

PTRange = "D" & NewRow & ":" & "R" & NewRow

summarywb.ActiveSheet.Activate
summarywb.ActiveSheet.Range(PTRange).Select
ActiveSheet.Paste Link:=True

'Adds "N" to closed column
summarywb.ActiveSheet.Cells(NewRow, 20) = "N"

CleanExit:
    'Line to display which line a new job was added to
    MsgBox NewJobNumber & " added to line " & NewRow

    'Close sourcewb
    sourcewb.Close savechanges:=False

    'Refresh Data (Note. Refreshes all links)
    RefreshAllLinks

    'Display back on
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    Exit Sub

NoReportTabError:
    MsgBox "No Reporting tab found on the specified Tracking workbook. Closing Macro."
    'Close sourcewb
    sourcewb.Close savechanges:=False

    'Display back on
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    Exit Sub

End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'
'This code checks for job numbers that are duplicate of the one to be added.
'
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Function DuplicateCheck(summarywb, FirstRow, LastRow, NewRow, NewJobNumber)

Dim CheckCell As String

summarywb.ActiveSheet.Activate

For i = FirstRow To LastRow
    Range("A" & i).Select
    Selection.Copy
    Range("A" & NewRow).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=Flase, Transpose:=False
    CheckCell = Cells(NewRow, 1).Value
    If CheckCell = NewJobNumber Then
        DuplicateCheck = 1
        Range("A" & NewRow).Clear
        Exit Function
    End If
    Range("A" & NewRow).Clear
Next i

End Function
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'
'This code refreshes all links in the active worksheet.
'
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Sub RefreshAllLinks()

'Minimize runtime
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'Initialize Variables
Dim summarywb As Workbook

'Set initial values
Set summarywb = ThisWorkbook

'Refresh all linked data
summarywb.ActiveSheet.Activate
summarywb.UpdateLink Name:=summarywb.LinkSources

'Display back on
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'
'This code moves highlighted line(s) of data from current to archive tab.
'
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Sub ArchiveData()

'Minimize runtime
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'Initialize Variables
Dim summarywb As Workbook
Dim LastRow As Long
Dim NewRow As Long

'Set initial values
Set summarywb = Workbooks("Project Status Summary.xlsm")

'Asks for confirmation
If MsgBox("Archive highlighted job(s)?", vbYesNo, "Confirm") = vbNo Then

    'Display back on
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    'Abort message
    MsgBox "Job(s) not archived."
    Exit Sub
End If

'Finds last non-blank row on Archive sheet
Worksheets("Archive").Activate
LastRow = summarywb.Sheets("Archive").Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row

'Assigns row number for a new line
NewRow = LastRow + 1

'Copies and pastes data from Current tab to Archive tab
Worksheets("Current").Activate
Selection.Copy
Worksheets("Archive").Activate
Range("A" & NewRow).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=Flase, Transpose:=False

''Displays confirmation message
MsgBox ("Job(s) archived.")

'Display back on
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Answer 1

如果副本间歇性失败，则可能是竞争条件。这是一个重复粘贴几次的小片段：

Sub PasteEx()
    On Error Resume Next
    Err.Clear
    ActiveSheet.Paste Link:=True
    If Err.Number = 0 Then
        GoTo PasteEx_Exit
    Else
        For i = 1 To 3
            Err.Clear
            ActiveSheet.Paste Link:=True
            If Err.Number = 0 Then
                GoTo PasteEx_Exit
            End If
            Application.Wait Now + TimeValue("0:00:01") ' Adjust as needed
        Next i
    End If
    On Error GoTo 0
    Err.Raise 1004

PasteEx_Exit:
    On Error GoTo 0
End Sub

添加此方法并将ActiveSheet.Paste Link:=True替换为PasteEx。那里有一个延迟。根据需要进行调整。由于我无法重现您的条件，我不确定它是否会对您有所帮助。试一试！

粘贴链接随机错误

1 个答案: