“ MASTER ”表单中的不同名称（过滤器字段6）和天数（过滤器字段20）的宏过滤器。过滤完工作表后，它会将过滤器字段6中“ Nils ”的所有内容复制到工作表“ Nils ”。
它认为它有效，但在检查结果后，我发现了一些我无法解决的问题。他不会复制符合条件的每一行（名称和＆gt; -9天）。 当我查看 MASTER 表时，我可以找到宏应该复制的行。
Sub DeleteFilterAndCopy()
Dim LASSSST As Long
Dim IP As Worksheet
Sheets("MASTER").Select
Set IP = ThisWorkbook.Worksheets("Input")
LASSSST = IP.Cells(Rows.Count, "B").End(xlUp).Row
Sheets("MASTER").Cells.clearcontents
Sheets("hideMASTER").Range("A4:U" & LASSSST).Copy
Sheets("MASTER").Range("A1").PasteSpecial xlPasteValues
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Sheets("Alex").Range("A2:T1000").clearcontents
Sheets("Anett Edith").Range("A2:T1000").clearcontents
Sheets("Angela").Range("A2:T1000").clearcontents
Sheets("Dirk").Range("A2:T1000").clearcontents
Sheets("Daniel").Range("A2:T1000").clearcontents
Sheets("Klaus").Range("A2:T1000").clearcontents
Sheets("Konrad").Range("A2:T1000").clearcontents
Sheets("Marion").Range("A2:T1000").clearcontents
Sheets("Martin").Range("A2:T1000").clearcontents
Sheets("Michael").Range("A2:T1000").clearcontents
Sheets("Mirko").Range("A2:T1000").clearcontents
Sheets("Nils").Range("A2:T1000").clearcontents
Sheets("Ulrike").Range("A2:T1000").clearcontents
Dim lngLastRow As Long
Dim AlexSheet As Worksheet, AnettEdithSheet As Worksheet, AngelaShett As Worksheet, DanielSheet As Worksheet
Dim DirkSheet As Worksheet, KlausSheet As Worksheet, Konradsheet As Worksheet
Dim MarionSheet As Worksheet, MartinSheet As Worksheet, MichaelSheet As Worksheet, MirkoSheet As Worksheet
Dim NilsSheet As Worksheet, Ulrikesheet As Worksheet
Set AlexSheet = Sheets("Alex")
Set AnettEdithSheet = Sheets("Anett Edith")
Set AngelaSheet = Sheets("Angela")
Set DanielSheet = Sheets("Daniel")
Set DirkSheet = Sheets("Dirk")
Set KlausSheet = Sheets("Klaus")
Set Konradsheet = Sheets("Konrad")
Set MarionSheet = Sheets("Marion")
Set MartinSheet = Sheets("Martin")
Set MichaelSheet = Sheets("Michael")
Set MirkoSheet = Sheets("Mirko")
Set NilsSheet = Sheets("Nils")
Set Ulrikesheet = Sheets("Ulrike")
lngLastRow = Cells(Rows.Count, "B").End(xlUp).Row
With ThisWorkbook.Sheets("MASTER")
.Range("T4").CurrentRegion.Sort Key1:=.Range("T4"), order1:=xlDescending, _
Header:=xlYes, OrderCustom:=1, DataOption1:=xlSortNormal
End With
With Range("B1:U" & lngLastRow)
.AutoFilter
.AutoFilter Field:=6, Criteria1:="Alexandra"
.AutoFilter Field:=20, Criteria1:=">=-9"
.Copy AlexSheet.Range("A1")
.AutoFilter Field:=6, Criteria1:="Anett / Edith"
.AutoFilter Field:=20, Criteria1:=">=-9"
.Copy AnettEdithSheet.Range("A1")
.AutoFilter Field:=6, Criteria1:="Angela"
.AutoFilter Field:=20, Criteria1:=">=-9"
.Copy AngelaSheet.Range("A1")
.AutoFilter Field:=6, Criteria1:="Daniel"
.AutoFilter Field:=20, Criteria1:=">=-9"
.Copy DanielSheet.Range("A1")
.AutoFilter Field:=6, Criteria1:="Dirk"
.AutoFilter Field:=20, Criteria1:=">=-9"
.Copy DirkSheet.Range("A1")
.AutoFilter Field:=6, Criteria1:="Klaus"
.AutoFilter Field:=20, Criteria1:=">=-9"
.Copy KlausSheet.Range("A1")
.AutoFilter Field:=6, Criteria1:="Konrad"
.AutoFilter Field:=20, Criteria1:=">=-9"
.Copy Konradsheet.Range("A1")
.AutoFilter Field:=6, Criteria1:="Marion"
.AutoFilter Field:=20, Criteria1:=">=-9"
.Copy MarionSheet.Range("A1")
.AutoFilter Field:=6, Criteria1:="Martin"
.AutoFilter Field:=20, Criteria1:=">=-9"
.Copy MartinSheet.Range("A1")
.AutoFilter Field:=6, Criteria1:="Michael"
.AutoFilter Field:=20, Criteria1:=">=-9"
.Copy MichaelSheet.Range("A1")
.AutoFilter Field:=6, Criteria1:="Mirko"
.AutoFilter Field:=20, Criteria1:=">=-9"
.Copy MirkoSheet.Range("A1")
.AutoFilter Field:=6, Criteria1:="Nils"
.AutoFilter Field:=20, Criteria1:=">=-9"
.Copy NilsSheet.Range("A1")
.AutoFilter Field:=6, Criteria1:="Ulrike"
.AutoFilter Field:=20, Criteria1:=">=-9"
.Copy Ulrikesheet.Range("A1")
.AutoFilter
End With
Sheets("INPUT").Select
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
可能是某种类型的计算限制吗？宏大约有1000行需要过滤并复制到13个不同的表格中。
答案 0 :(得分：0)
这不是完整的答案，只是一种更短，更清洁，更通用的方式。 请参阅我在代码中的注释，其中一些是问题
Option Explicit
Sub DeleteFilterAndCopy()
Dim LASSSST As Long
Dim IP As Worksheet
Dim Sht As Worksheet
Dim ShtNamesArr As Variant
Dim i As Long
' put all your desired sheet names into array
ShtNamesArr = Array("Alex", "Anett Edith", "Angela", "Dirk", "Daniel", "Klaus", "Konrad", "Marion", "Martin", "Michael", "Mirko", "Nils", "Ulrike")
Set IP = ThisWorkbook.Worksheets("Input")
' get last row in Column B fron sheet "Input"
LASSSST = IP.Cells(IP.Rows.Count, "B").End(xlUp).Row
Sheets("MASTER").Cells.ClearContents
' using Last row from sheet "Input" and use it in sheet "hideMASTER" ???
Sheets("hideMASTER").Range("A4:U" & LASSSST).Copy
Sheets("MASTER").Range("A1").PasteSpecial xlPasteValues
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
' Method 1 of clearing contents in Range A2:T1000 in all specific sheets
For i = LBound(ShtNamesArr) To UBound(ShtNamesArr)
On Error Resume Next
Sheets(ShtNamesArr(i)).Range("A2:T1000").ClearContents ' this method might return an error if sheet name not found
On Error GoTo 0
Next i
' Method 2 of clearing contents in Range A2:T1000 in all specific sheets
For Each Sht In ThisWorkbook.Sheets
Select Case Sht.Name
Case "Alex", "Anett Edith", "Angela", "Dirk", "Daniel", "Klaus", "Konrad", "Marion", "Martin", "Michael", "Mirko", "Nils", "Ulrike"
Sht.Range("A2:T1000").ClearContents
End Select
Next Sht
Dim lngLastRow As Long
' which sheet is this suppose to be ???
lngLastRow = Cells(Rows.Count, "B").End(xlUp).Row
With ThisWorkbook.Sheets("MASTER")
.Range("T4").CurrentRegion.Sort Key1:=.Range("T4"), order1:=xlDescending, _
Header:=xlYes, OrderCustom:=1, DataOption1:=xlSortNormal
End With
With Range("B1:U" & lngLastRow)
.AutoFilter
' lppo through all sheet names array elements, and per each element filter the table and copy it to the relevant sheet
For i = LBound(ShtNamesArr) To UBound(ShtNamesArr)
.AutoFilter Field:=6, Criteria1:=ShtNamesArr(i)
.AutoFilter Field:=20, Criteria1:=">=-9"
.Copy Sheets(ShtNamesArr(i)).Range("A1")
Next i
End With
Sheets("INPUT").Select
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub