Попытка объединить две части кодирования VBA в одну

Question

Сначала позвольте мне сказать, что я новичок в кодировании VBA. Моя электронная таблица имеет 8 вкладок (1 скрытая и 1 диаграмма). Из других 6 вкладок, я хотел бы, чтобы код мог работать на них, я просто не знаю как. У меня есть два набора кода, и я пытаюсь их объединить. Это коды, связанные с событиями. Я могу заставить их работать отдельно, но только на указанном листе. Я тестирую их на вкладке «Новые». Первый код сортирует строки после того, как дата введена в столбец «H». Другой код вырезает и вставляет всю строку в соответствующую вкладку на основе выбора из выпадающего списка в столбце «O». Я создал функцию вызова для обоих, однако, только первый код будет делать что угодно. Вот что у меня пока так:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngChng As Range

Set rngChng = Intersect(Target, Range("H:H"))

If rngChng Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
Application.ScreenUpdating = False
    Call AutoSort(rngChng)

Set rngChng = Intersect(Target, Range("O:O"))
If rngChng Is Nothing Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
    Call CopyNPaste(rngChng)
Application.ScreenUpdating = True
End Sub

Sub AutoSort(rngChng As Range)
    Range("A2:O1000").Sort Key1:=Range("H1"), Order1:=xlAscending, Header:=xlNo
End Sub

Sub CopyNPaste(rngChng As Range)
    Dim ws As Worksheet
    For Each ws In Sheets
    If ws.Name <> "New" Then
        If ws.Name = Target Then
        Target.EntireRow.Copy Sheets(ws.Name).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        Target.EntireRow.Delete Shift:=x1Up
        End If
    End If
    Next ws
End Sub

Answer 1

Чтобы запустить один и тот же код из множества листов, переместите код в модуль. Используйте insert-> module в строке меню, если нет других, он будет называться Module1. В каждом соответствующем листе добавьте код

Private Sub Worksheet_Change(ByVal Target As Range)
  Call Module1.sortOrCopy(Target)
End Sub

Поместите sub модуля sortOrCopy в модуль. Я бы предложил использовать значение Target.column вместо пересечений для управления потоком программы. Поместите проверку target.cells.count один раз в начале. Передайте параметры своим двум подпрограммам.

Sub sortOrCopy(ByVal Target As Range)

    If Target.Cells.Count > 1 Then Exit Sub

    Dim ws As Worksheet
    Set ws = Target.Parent

    If Target.Column = 8 Then ' col H
        Call AutoSort(ws)
    ElseIf Target.Column = 15 Then ' col O
        Call CopyNPaste(Target)
    End If

End Sub

Для подпрограммы автосортировки единственным требуемым параметром является лист, который будет Target.parent. Вы можете установить диапазон сортировки вместо жесткого кодирования, используя .end (xlUp.row, как у вас в другом подпункте.

Sub AutoSort(ws As Worksheet)

    Dim iLastRow As Long
    ' last row of sort range
    iLastRow = ws.Range("H" & Rows.Count).End(xlUp).Row

    Application.ScreenUpdating = False
    Range("A2:O" & iLastRow).Sort Key1:=Range("H1"), Order1:=xlAscending, Header:=xlNo
    Application.ScreenUpdating = True

End Sub

Для подпункта CopyNPaste передайте Target так, чтобы источник, строка и назначение может быть определено. Попробуйте структурировать код простыми шагами, не делая слишком много в одной строке. Если код не работает должным образом, тогда проще добавить операторы debug.print или msgBox на различных этапах. Если .. Конец, если вы не хотите, чтобы пользователь подтвердил изменение.

Sub CopyNPaste(Target)

    Dim wsCopyTo As Worksheet, iInsertRow As Long, text As String
    Set wsCopyTo = Sheets(Target.Value)
    ' find last row on CopyTo sheet, insert below
    iInsertRow = 1 + wsCopyTo.Range("A" & Rows.Count).End(xlUp).Row

    text = "Copy line to sheet " & wsCopyTo.Name & " row " & iInsertRow
    If MsgBox(text, vbYesNo) = vbYes Then
         With Target.EntireRow
            .Copy wsCopyTo.Range("A" & iInsertRow)
            .Delete Shift:=xlShiftUp
         End With
    End If
End Sub