Справка VBA - Ошибка времени выполнения 5: неверный вызов или аргумент процедуры, только при первом запуске

Question

В строке 37 «sh_DP_old.Copy After: = sh_new» сообщается «Ошибка времени выполнения 5»: недопустимый вызов процедуры или аргумент »только при первом запуске. После нажатия «отладка» и ничего не делая, кроме повторного запуска кода, он работает хорошо. Ниже приведен код. Любая помощь будет принята с благодарностью.

Option Explicit

Public Function SheetFromCodeName(aName As String, wb As Workbook) As Worksheet

    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        If sh.CodeName = aName Then
           Set SheetFromCodeName = sh
           Exit For
        End If
    Next sh

End Function

Sub Note_Transfer()


    Dim lastrow As Long
    Dim MatchRow As Long
    Dim firstopenrow As Long
    Dim i As Long
    Dim sh_old As Worksheet
    Dim sh_new As Worksheet
    Dim sh_DP_old As Worksheet
    Dim sh_DP_new As Worksheet
    Dim wb_old As Workbook
    Dim wb_new As Workbook

    Set wb_old = Workbooks(Workbooks.Count - 1)
    Set wb_new = Workbooks(Workbooks.Count)
    Set sh_old = SheetFromCodeName("Sheet1", wb_old)
    Set sh_new = SheetFromCodeName("Sheet1", wb_new)

' transfer note if record matches
    Set sh_DP_old = wb_old.Sheets("Discharged Patient")

    sh_DP_old.Copy After:=sh_new

    Set sh_DP_new = wb_new.Sheets("Discharged Patient")

    lastrow = sh_old.Cells(Rows.Count, "A").End(xlUp).Row

    For i = 2 To lastrow

    If sh_old.Cells(i, 25) <> "Discharged patient" Then

    MatchRow = Application.WorksheetFunction.Match(sh_old.Cells(i, 23).Value, sh_new.Range("W:W"), 0)

    sh_new.Cells(MatchRow, 26).Resize(, 7).Value = sh_old.Cells(i, 26).Resize(, 7).Value

    Else

    firstopenrow = sh_DP_new.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row
    sh_DP_new.Cells(firstopenrow, 1).Resize(, 32).Value = sh_old.Cells(i, 1).Resize(, 32).Value

    End If
    Next

    sh_new.Select

End Sub

Answer 1

Сначала нажмите Доверительный доступ к объектной модели проекта VBA через настройки макроса Excel. Во-вторых, заменить

Set sh_old = SheetFromCodeName("Sheet1", wb_old) 
Set sh_new = SheetFromCodeName("Sheet1", wb_new) 

с

With wb_old 
Set sh_old = .Worksheets(CStr(.VBProject.VBComponents("Sheet1").Properties(7))) 
End With 
With wb_new 
Set sh_new= .Worksheets(CStr(.VBProject.VBComponents("Sheet1").Properties(7)))
End With

И заслуга @John_Cunningham от Удеми.
Модифицированный весь код вставлен ниже.

Option Explicit

Private Function SheetFromCodeName(aName As String, wb As Workbook) As Excel.Worksheet

    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        If sh.CodeName = aName Then
           Set SheetFromCodeName = sh
           Exit For
        End If
    Next sh

End Function

Sub Note_Transfer()


    Dim lastrow As Long
    Dim MatchRow As Long
    Dim firstopenrow As Long
    Dim i As Long
    Dim sh_old As Worksheet
    Dim sh_new As Worksheet
    Dim sh_DP_old As Worksheet
    Dim sh_DP_new As Worksheet
    Dim wb_old As Workbook
    Dim wb_new As Workbook

    Set wb_old = Workbooks(Workbooks.Count - 1)
    Set wb_new = Workbooks(Workbooks.Count)

    With wb_old
    Set sh_old = .Worksheets(CStr(.VBProject.VBComponents("Sheet1").Properties(7)))
    End With
    With wb_new
    Set sh_new = .Worksheets(CStr(.VBProject.VBComponents("Sheet1").Properties(7)))
    End With

' transfer note if record matches
    Set sh_DP_old = wb_old.Sheets("Discharged Patient")

    sh_DP_old.Copy After:=sh_new

    Set sh_DP_new = wb_new.Sheets("Discharged Patient")

    lastrow = sh_old.Cells(Rows.Count, "A").End(xlUp).Row

    For i = 2 To lastrow

    If sh_old.Cells(i, 25) <> "Discharged patient" Then

    MatchRow = Application.WorksheetFunction.Match(sh_old.Cells(i, 23).Value, sh_new.Range("W:W"), 0)

    sh_new.Cells(MatchRow, 26).Resize(, 7).Value = sh_old.Cells(i, 26).Resize(, 7).Value

    Else

    firstopenrow = sh_DP_new.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row
    sh_DP_new.Cells(firstopenrow, 1).Resize(, 32).Value = sh_old.Cells(i, 1).Resize(, 32).Value

    End If
    Next


    sh_new.Select

End Sub