Question

此宏基本上会根据主工作表上的条件将行复制到其他工作表。如果主工作表上的数据发生更改，它将使用新数据更新每个工作表。但另一个问题是，当用户完全删除主数据中的一个条件时，它不会删除与已删除的条件对应的表单。

所以...我的下一个场景是，如果用户完全删除主表上的一个条件，它还将删除与主数据上已删除的条件相对应的表单，如果有新数据，则将使用该新数据更新每张工作表

宏代码是这样的：

Sub test()
    Dim col As New Collection
    Dim wsAll As Worksheet, wsNew As Worksheet
    Dim LastRow As Long
    Dim c As Range, rng As Range, copyRng As Range
    Dim el
    Application.ScreenUpdating = False

    Set wsAll = ThisWorkbook.Worksheets("Data")

    With wsAll
        Set rng = .Range("B1:B" & .Range("B" & .Rows.Count).End(xlUp).Row)

        'get all unique values except header
        For Each c In rng.Offset(1).Resize(rng.Rows.Count - 1)
            On Error Resume Next
                col.Add CStr(c.Value), CStr(c.Value)
            On Error GoTo 0
        Next c
        'disable all filters
        .AutoFilterMode = False

        With rng
            For Each el In col
                .AutoFilter Field:=1, Criteria1:=el

                On Error Resume Next
                Set wsNew = ThisWorkbook.Worksheets(el)
                On Error GoTo 0
                If wsNew Is Nothing Then
                    Set wsNew = ThisWorkbook.Worksheets.Add
                    wsNew.Name = el
                End If

                If WorksheetFunction.CountA(wsNew.Range("A:A")) = 0 Then
                    lastRowNew = 1
                    'if it's new sheet copy with header
                    Set copyRng = .SpecialCells(xlCellTypeVisible)
                Else
                    lastRowNew = 2
                    Set copyRng = .Offset(1).Resize(rng.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
                   ' Set copyRng = .SpecialCells(xlCellTypeVisible)
                End If

                wsNew.Rows("2:" & Rows.Count).ClearContents
                copyRng.EntireRow.Copy Destination:=wsNew.Range("A" & lastRowNew)

                Set wsNew = Nothing
            Next
        End With

        'disable all filters
        .AutoFilterMode = False
    End With
    wsAll.Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Answer 1

试试这个：

Sub DistributeRows()
    Dim wsAll As Worksheet
    Dim wsCrit As Worksheet
    Dim wsNew As Worksheet
    Dim LastRow As Long
    Dim LastRowCrit As Long
    Dim lastRowNew As Long
    Dim I As Long

    Set wsAll = Worksheets("Data") ' change All to the name of the worksheet the existing   data is on

    LastRow = wsAll.Range("C" & Rows.Count).End(xlUp).Row

    Set wsCrit = Worksheets.Add

    ' column A has the criteria eg project ref
    wsAll.Range("C1:C" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True

    LastRowCrit = wsCrit.Range("A" & Rows.Count).End(xlUp).Row
    For I = 2 To LastRowCrit
        On Error Resume Next
        Set wsNew = ThisWorkbook.Worksheets(wsCrit.Range("A2").Value)
        On Error GoTo 0
        If wsNew Is Nothing Then
            Set wsNew = ThisWorkbook.Worksheets.Add
            wsNew.Name = wsCrit.Range("A2").Value
        End If
        lastRowNew = wsNew.Range("A" & Rows.Count).End(xlUp).Row
        wsAll.Rows("1:" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A2"), _
            CopyToRange:=wsNew.Range("A" & lastRowNew), Unique:=False
        wsCrit.Rows(2).Delete
        Set wsNew = Nothing
    Next I

    Application.DisplayAlerts = False
    wsCrit.Delete
    Application.DisplayAlerts = True

End Sub

<强> UPD：

以下是使用Collection的另一种方法：

Sub test()
    Dim col As New Collection
    Dim wsAll As Worksheet, wsNew As Worksheet
    Dim LastRow As Long
    Dim c As Range, rng As Range, copyRng As Range
    Dim el
    Application.ScreenUpdating = False

    Set wsAll = ThisWorkbook.Worksheets("Data")

    With wsAll
        Set rng = .Range("B1:B" & .Range("B" & .Rows.Count).End(xlUp).Row)

        'get all unique values except header
        For Each c In rng.Offset(1).Resize(rng.Rows.Count - 1)
            On Error Resume Next
                col.Add CStr(c.Value), CStr(c.Value)
            On Error GoTo 0
        Next c
        'disable all filters
        .AutoFilterMode = False

        With rng
            For Each el In col
                .AutoFilter Field:=1, Criteria1:=el

                On Error Resume Next
                Set wsNew = ThisWorkbook.Worksheets(el)
                On Error GoTo 0
                If wsNew Is Nothing Then
                    Set wsNew = ThisWorkbook.Worksheets.Add
                    wsNew.Name = el
                End If
                Set copyRng = .SpecialCells(xlCellTypeVisible)

                wsNew.Cells.ClearContents
                copyRng.EntireRow.Copy Destination:=wsNew.Range("A1")

                '***************************************
                'For pasting only values use this one
                'copyRng.EntireRow.Copy
                'wsNew.Range("A1").PasteSpecial xlPasteValues
                '***************************************

                Set wsNew = Nothing
            Next
        End With

        'disable all filters
        .AutoFilterMode = False
    End With

    'delete sheets
    Application.DisplayAlerts = False
    For Each wsNew In ThisWorkbook.Worksheets
        If wsNew.Name <> wsAll.Name Then
            If IsError(Application.Match(wsNew.Name, wsAll.Range("B:B"), 0)) Then                   
               wsNew.Delete
            End If
        End If
    Next wsNew
    Application.DisplayAlerts = True        

    wsAll.Select

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

如果工作表不在主标准上，则删除工作表

1 个答案: