Копировать разные строки на основе Excel VBA

Question

Я пытаюсь auto-copy rows от мастера worksheet до отдельного worksheet.Это происходит, когда определенное значение вводится в Column B в Master sheet.Например, если ABC введено в Column B в Master, эти rows будут автоматически скопированы на отдельный лист под названием ABC.

Проблема в том, что у меня есть другие значения, которые я хочу скопировать в другие таблицы.Например, если в столбце B в поле Master введено DEF, то автоматически скопируйте его на отдельный лист с именем DEF.Я не знаю, как это сделать.

Приведенный ниже код автоматически копирует все строки, когда Change вводится в Column B.Это прекрасно работает, но я также хочу добавить еще одну функцию, которая copies все rows, когда вводится «Задержка».

Sub FilterAndCopy()
    Dim rng As Range, sht1 As Worksheet, sht2 As Worksheet

    Set sht1 = Worksheets("Master")
    Set sht2 = Worksheets("Change")

sht2.UsedRange.ClearContents

With Intersect(sht1.Columns("B:BP"), sht1.UsedRange)
    .Cells.EntireColumn.Hidden = False ' unhide columns
    If .Parent.AutoFilterMode Then .Parent.AutoFilterMode = False

    .AutoFilter field:=1, Criteria1:="Change"

    .Range("A:F, BL:BO").Copy Destination:=sht2.Cells(4, "B")
    .Parent.AutoFilterMode = False

    .Range("H:BK").EntireColumn.Hidden = True ' hide columns
    End With
End Sub

Этот код просто копирует команду Изменить строки из мастер-листа на лист изменения.

Однако я хочу добавить еще одну функцию, которая копирует строки задержки из мастер-листа в лист задержки.Я просто не уверен, может ли это быть включено в код выше?Или, если я могу сделать следующее:

Sub FilterAndCopy()
    Dim rng As Range, sht1 As Worksheet, sht3 As Worksheet

    Set sht1 = Worksheets("Master")
    Set sht3 = Worksheets("Delay")

sht3.UsedRange.ClearContents

With Intersect(sht1.Columns("B:BP"), sht1.UsedRange)
    .Cells.EntireColumn.Hidden = False ' unhide columns
    If .Parent.AutoFilterMode Then .Parent.AutoFilterMode = False

    .AutoFilter field:=1, Criteria1:="Delay"

    .Range("A:B, BJ:BO").Copy Destination:=sht2.Cells(4, "B")
    .Parent.AutoFilterMode = False

    .Range("D:BI").EntireColumn.Hidden = True ' hide columns
    End With
End Sub

ОБРАТИТЕ ВНИМАНИЕ: Этот макрос должен быть запущен без запуска сценария.

Answer 1

Вернемся к этому снова. Обратите внимание, что это проверено и работает, поэтому, пожалуйста, дважды проверьте, прежде чем что-либо менять (как вы делали с B4 на B5 в предыдущем тесте).

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False

    If Not Intersect(Target, Range("B:B")) Is Nothing Then

        Dim Sh1 As Worksheet: Set Sh1 = Me
        Dim Sh2 As Worksheet: Set Sh2 = Worksheets("CHANGE OF NO'S")
        Dim Sh3 As Worksheet: Set Sh3 = Worksheets("ECS")
        Dim R0 As Range
        Dim R1 As Range: Set R1 = Intersect(Sh1.UsedRange, Sh1.Columns(2))

        'Clear data in sheets
        Sh2.Cells.Clear
        Sh2.Range("B4") = "start"
        Sh3.Cells.Clear
        Sh3.Range("B4") = "start"

        'Clear autofilter
        If Sh1.AutoFilterMode Then Sh1.AutoFilterMode = False

        For Each R0 In R1
            Select Case Trim(R0.Value)
                Case Is = "Change"
                    Intersect(R0.EntireRow, Sh1.Range("A:F,BL:BO")).Copy Sh2.Cells(Sh2.Rows.Count, 2).End(xlUp).Offset(1, 0)
                Case Is = "Early"
                    Intersect(R0.EntireRow, Sh1.Range("A:D,O:R,BL:BO")).Copy Sh3.Cells(Sh3.Rows.Count, 2).End(xlUp).Offset(1, 0)
            End Select
        Next R0

        Sh2.Range("B4") = ""
        Sh3.Range("B4") = ""

    End If

Application.ScreenUpdating = True
End Sub

Это должно быть вставлено в код листа "Master" или как вы его назвали. Смотрите ниже:

Теперь код будет запускаться, когда вы вводите что-либо в столбец «B» на мастер-листе. Смотрите ниже:

Sheet Master (ввод нового текста «Изменить» в столбце «B»):

Обновлены листы «СМЕНА НЕТ» и «ECS»:

Answer 2

Могу ли я предложить немного другой подход:

Sub Copy_criteria()

    Dim Sh1 As Worksheet: Set Sh1 = Worksheets("SHIFT LOG")
    Dim Sh2 As Worksheet: Set Sh2 = Worksheets("CHANGE OF NO'S")
    Dim Sh3 As Worksheet: Set Sh3 = Worksheets("ECS")
    Dim R0 As Range
    Dim R1 As Range: Set R1 = Intersect(Sh1.UsedRange, Sh1.Columns(2))

    'Clear data in sheets
    Sh2.Cells.Clear
    Sh2.Range("B4") = "start"
    Sh3.Cells.Clear
    Sh3.Range("B4") = "start"

    'Clear autofilter
    If Sh1.AutoFilterMode Then Sh1.AutoFilterMode = False

    For Each R0 In R1
        Select Case Trim(R0.Value)
            Case Is = "Change"
                Intersect(R0.EntireRow, Sh1.Range("A:F,BL:BO")).Copy Sh2.Cells(Sh2.Rows.Count, 2).End(xlUp).Offset(1, 0)
            Case Is = "Early"
                Intersect(R0.EntireRow, Sh1.Range("A:D,O:R,BL:BO")).Copy Sh3.Cells(Sh3.Rows.Count, 2).End(xlUp).Offset(1, 0)
        End Select
    Next R0

    Sh2.Range("B4") = ""
    Sh3.Range("B4") = ""
End Sub