过滤并复制

Question

有几个与此主题有关的问题，但我有些挣扎。

我有一个主sheet，它存储各种信息。我使用Column B隐藏/取消隐藏其他columns。因此，对于列B中输入的每个不同值，它将显示相应的Columns。例如如果在X中输入了Column B，将显示Col C:F，而Col G:I将被隐藏。

这工作正常，但我想自动从此工作表中copy相同值分开sheets。例如抓住MASTER中的所有X's，然后复制到仅包含sheet的单独X's中。

我可以执行此操作，但只能通过使用需要触发的macro来完成。如果我需要copy大量rows，这不是很有效。特别是如果您只更新了1 row，但需要复制所有内容。

我想在输入值后自动自动复制。无需触发宏

这是script在主columns中特定的sheet的隐藏/取消隐藏：

Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Range("B:B")) Is Nothing Then
        On Error GoTo safe_exit
        Application.EnableEvents = False
        Dim t As Range
        For Each t In Intersect(Target, Range("B:B"))
            Select Case (t.Value)
                Case "Change of Numbers"
                    Columns("B:BP").EntireColumn.Hidden = False
                    Columns("H:BL").EntireColumn.Hidden = True
                    'do nothing
            End Select
        Next t

    End If

safe_exit:
    Application.EnableEvents = True
End Sub

由于无法在此脚本中添加单独的Worksheet_Change以进行自动复制，因此我对如何执行此操作感到有些困惑

我目前正在使用以下脚本。这会将适当的rows复制到相应的sheet。但它仅在触发时有效。我希望copy row填写一次后自动完成。

@Gexas，这怎么样？

Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Range("B:B")) Is Nothing Then
        On Error GoTo safe_exit
        Application.EnableEvents = False
        Dim t As Range
        For Each t In Intersect(Target, Range("B:B"))
            Select Case (t.Value)
                Case "Change of Numbers"
                    Columns("B:BP").EntireColumn.Hidden = False
                    Columns("H:BL").EntireColumn.Hidden = True
                    'do nothing
            End Select
        Next t

    End If
safe_exit:
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rng As Range, sht1 As Worksheet, sht2 As Worksheet

    Set sht1 = Worksheets("MASTER")
    Set sht2 = Worksheets("CON")

    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 of Numbers"

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

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

Answer 1

过滤并复制

如果将“ Sub”移到工作表代码（“主”）中，则可能像在“ Private Sub”中那样丢失其中的“ sht1”，如果不只是将FilterAndCopy行适当地添加到“ Private Sub”中'。

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    On Error GoTo safe_exit

    ' Something has changed in Column "B"
    If Not Intersect(Target, Range("B:B")) Is Nothing Then

        Application.EnableEvents = False

    ' *******************
        FilterAndCopy ' *
    ' *******************

        Dim t As Range

        For Each t In Intersect(Target, Range("B:B"))
            Select Case (t.Value)
                Case "Change of Numbers"
                    Columns("B:BP").EntireColumn.Hidden = False
                    Columns("H:BL").EntireColumn.Hidden = True
                    'do nothing
            End Select
        Next t

    End If

safe_exit:

    Application.EnableEvents = True

End Sub


'****************
Sub FilterAndCopy()

    Dim rng As Range, sht1 As Worksheet, sht2 As Worksheet

    Set sht1 = Worksheets("MASTER")
    Set sht2 = Worksheets("CON")

    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 of Numbers"
                .Range("A:F, BL:BO").Copy Destination:=sht2.Cells(2, "B")
            .Parent.AutoFilterMode = False
        .Range("H:BK").EntireColumn.Hidden = True ' hide columns
    End With

End Sub
'****************

Answer 2

Worksheet_Change事件可以同时包含两个函数。由于代码是从第一行到最后一行读取的，因此按顺序，VBA将从第二个代码中复制内容，然后隐藏列。假设其他一切都很好，下面的代码应该可以工作。请注意，我无法测试它，也没有检查其他错误。刚刚更改了订单。

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rng As Range, sht1 As Worksheet, sht2 As Worksheet

    Set sht1 = Worksheets("MASTER")
    Set sht2 = Worksheets("CON")

    sht2.UsedRange.ClearContents

    If Not Intersect(Target, Range("B:B")) Is Nothing Then
        On Error GoTo safe_exit
        Application.EnableEvents = False

        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 of Numbers"

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

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

        Dim t As Range
        For Each t In Intersect(Target, Range("B:B"))
            Select Case (t.Value)
            Case "Change of Numbers"
                Columns("B:BP").EntireColumn.Hidden = False
                Columns("H:BL").EntireColumn.Hidden = True
                'do nothing
            End Select
        Next t

    End If

    safe_exit:
    Application.EnableEvents = True
End Sub

复制行而不触发宏VBA

2 个答案:

过滤并复制