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

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

所以…我的下一个场景是，如果用户完全删除了母表上的条件之一，它也将删除与主数据上删除的条件相对应的表单，如果有新的数据，它将更新每个新数据表

macros代码是这样的：

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