复制基于不同行的 Excel VBA

Question

我正在尝试将 auto-copy rows 从主 worksheet 转换为单独的 worksheet。当在 Master sheet 中将特定值输入到 Column B 时，会发生这种情况。例如。如果 ABC 在 Master 中输入 Column B，这些 rows 将自动复制到名为 ABC 的单独工作表中。

问题是我有其他值要复制到其他工作表中。例如，如果在 Master 的 B 列中输入了 DEF，则自动复制到名为 DEF 的单独工作表中。我不知道该怎么做。

当Change 输入Column B 时，下面的代码会自动复制所有行。这工作正常，但我还想添加另一个函数，当输入“延迟”时，copies all 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

这将被插入“主”工作表代码或您所称的任何内容上。见下文：

现在，当您在主表的“B”列中键入任何内容时，代码将运行。见下文：

Sheet Master（在“B”列中输入新的“更改”文本）：

更新了“CHANGE OF NO'S”和“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