Проблема с вызовом процедуры из Workbook_SheetChange

Я создал рабочую книгу с несколькими листами, требующими множества двусторонних связанных ячеек на разных листах в одной и той же книге. Поэтому, если я отредактирую ячейку B5 на листе A, она автоматически обновит ячейку J2 на листе B с тем же значением. И наоборот, если я обновлю ячейку J2 на рабочем листе B, она автоматически обновит ячейку B5 на рабочем листе A. Чтобы выполнить двустороннюю ссылку, я включил следующий код в ThisWorkbook:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Sh.Name = "Smith,Joe" Then
        If Not Application.Intersect(Target, Range("B4")) Is Nothing Then
            Application.EnableEvents = False
            If Target.Parent.Name = "SomeProject" Then
                Sheets("Smith,Joe").Range("B4") = Target
            Else
                Sheets("SomeProject").Range("B10") = Target
            End If
            Application.EnableEvents = True
        End If
    End If
    If Sh.Name = "SomeProject" Then
        If Not Application.Intersect(Target, Range("B10")) Is Nothing Then
            Application.EnableEvents = False
            If Target.Parent.Name = "Smith,Joe" Then
                Sheets("SomeProject").Range("B10") = Target
            Else
                Sheets("Smith,Joe").Range("B4") = Target
            End If
            Application.EnableEvents = True
        End If
    End If
    If Sh.Name = "Smith,Joe" Then
        If Not Application.Intersect(Target, Range("C4")) Is Nothing Then
            Application.EnableEvents = False
            If Target.Parent.Name = "SomeProject" Then
                Sheets("Smith,Joe").Range("C4") = Target
            Else
                Sheets("SomeProject").Range("D10") = Target
            End If
            Application.EnableEvents = True
        End If
    End If
    If Sh.Name = "SomeProject" Then
        If Not Application.Intersect(Target, Range("D10")) Is Nothing Then
            Application.EnableEvents = False
            If Target.Parent.Name = "Smith,Joe" Then
                Sheets("SomeProject").Range("D10") = Target
            Else
                Sheets("Smith,Joe").Range("C4") = Target
            End If
            Application.EnableEvents = True
        End If
    End IF
    'This continues with for many different people/projects
End Sub

Это работало без проблем, пока процедура не столкнулась с пределом в 64 КБ (узнал об этом на форуме). Чтобы обойти ограничение, я создал несколько отдельных процедур, вызываемых из основного процесса, но ячейки больше не обновляются автоматически. После бесчисленных ошибок и посещений множества форумов я закончил тем, что WorkSheet_Change в ThisWorkbook вызывает контролирующий процесс в модуле, а все ссылки на рабочие листы и ячейки передаются в виде переменных. Это больше не обновляет ячейки на любом листе. Как сейчас, я получаю ошибку времени выполнения 91 (переменная объекта или переменная блока не установлена), когда я выполняю код модуля в подпрограмме ChangeLogic.

Код этойрабочей книги:

Option Explicit

Public Sh As Object
Public Target As Range
Public ResourceSheet As Object
Public ProjectSheet As Object
Public ResourceCell As String
Public ProjectCell As String

Private Sub Worksheet_Change(ByVal Sh As Object, ByVal Target As Range)

   Run "Main"

End Sub

Код в "Основном" модуле:

Sub Main()

    Call JoeMain

End Sub

Sub JoeMain()

    Set ResourceSheet = Sheets("Smith,Joe")
    Set ProjectSheet = Sheets("SomeProject")

    Call Joe1
    Call ChangeLogic(Sh, Target, ResourceSheet, ProjectSheet, ResourceCell, ProjectCell)

    Call Joe2
    Call ChangeLogic(Sh, Target, ResourceSheet, ProjectSheet, ResourceCell, ProjectCell)

    'Continues on for all cases involing Joe Smith.  I haven't gotten to iterating through project names as of yet

End Sub

Sub Joe1()

    ResourceCell = "B4"
    ProjectCell = "B10"

End Sub

Sub Joe2()

    ResourceCell = "C4"
    ProjectCell = "D10"

End Sub

Sub ChangeLogic(Sh, Target, ResourceSheet, ProjectSheet, ResourceCell, ProjectCell)
    If Sh.Name = ResourceSheet.Name Then
        If Not Application.Intersect(Target, Range(ResourceCell)) Is Nothing Then
            Application.EnableEvents = False
            If Target.Parent.Name = ProjectSheet.Name Then
                Sheets(ResourceSheet.Name).Range(ResourceCell) = Target
            Else
                Sheets(ProjectSheet.Name).Range(ProjectCell) = Target
            End If
            Application.EnableEvents = True
        End If
    End If
    If Sh.Name = ProjectSheet.Name Then
        If Not Application.Intersect(Target, Range(ProjectCell)) Is Nothing Then
            Application.EnableEvents = False
            If Target.Parent.Name = ResourceSheet.Name Then
            Sheets(ProjectSheet.Name).Range(ProjectCell) = Target
            Else
                Sheets(ResourceSheet.Name).Range(ResourceCell) = Target
            End If
            Application.EnableEvents = True
        End If
    End If
End Sub

На данный момент мои цвета новичка показывают, и я нахожусь над моей головой. Любые предложения о том, что я делаю неправильно и как я могу заставить это работать?

Благодарю.

Источник

1 ответ

Я устал набирать комментарии, поэтому я мог бы также напечатать здесь и прояснить, что я говорю.

Я не уверен, как вы достигли лимита в 64 КБ. Как упоминалось в комментариях выше, вы можете написать свой код более структурированным / компактным способом. В настоящее время ваш код 44 линии, исключая Sub/End Sub/Comments Тот же код может быть написан на 24 линии

Так что это прямая экономия 20 строк!!!,

Представьте себе, насколько уменьшится ваш окончательный код, когда вы удалите все ненужное Application.EnableEvents/IF-ENDIF

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    On Error GoTo Whoa

    Application.EnableEvents = False

    Select Case Sh.Name
    Case "Smith,Joe"
        If Not Application.Intersect(Target, Range("B4")) Is Nothing Then _
        If Target.Parent.Name = "SomeProject" Then Sheets("Smith,Joe").Range("B4") = Target Else _
        Sheets("SomeProject").Range("B10") = Target

        If Not Application.Intersect(Target, Range("C4")) Is Nothing Then _
        If Target.Parent.Name = "SomeProject" Then Sheets("Smith,Joe").Range("C4") = Target Else _
        Sheets("SomeProject").Range("D10") = Target
    Case "SomeProject"
        If Not Application.Intersect(Target, Range("B10")) Is Nothing Then _
        If Target.Parent.Name = "Smith,Joe" Then Sheets("SomeProject").Range("B10") = Target Else _
        Sheets("Smith,Joe").Range("B4") = Target

        If Not Application.Intersect(Target, Range("D10")) Is Nothing Then _
        If Target.Parent.Name = "Smith,Joe" Then Sheets("SomeProject").Range("D10") = Target Else _
        Sheets("Smith,Joe").Range("C4") = Target

        'This continues with for many different people/projects
    End Select
LetsContinue:
    Application.EnableEvents = True
    Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub
Источник
Другие вопросы по тегам