从高级filter粘贴

我被困在一条线上，不知道如何解决这个错误。 我用一个先进的filter过滤不同的名字来划分列表中的行，然后复制单个表格中的数据，但是卡在一行中，最后一行在下一行之前：“newWS.Range（”A1“）。 ”。 我从debugging中得到错误1004：

Private Sub loopfilter() Dim thisWB As Workbook Dim filterws As Worksheet Dim howto As Worksheet Dim advfilter As Range Dim Postenws As Worksheet Dim VersandRange As Range Dim rng As Range Dim Name As String Set thisWB = ThisWorkbook Set filterws = thisWB.Sheets("Filtro") Set howto = thisWB.Sheets("How to") Set advfilter = filterws.Range("A1:AK2") Set Postenws = thisWB.Sheets("Alle gemahnten Posten (2)") Set VersandRange = howto.Range("J2", Cells(Rows.Count, "j").End(xlUp)) Dim newWS As Worksheet For Each rng In VersandRange filterws.Range("AK2") = rng.Value Application.CutCopyMode = False Postenws.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=advfilter, _ CopyToRange:=filterws.Range("A5"), _ Unique:=False filterws.Range("a5").CurrentRegion.Copy Set newWS = thisWB.Sheets.Add newWS.Name = rng.Value newWS.Range("A1").Paste Next End Sub 

任何想法为什么它不工作？

谢谢

Answer 1

试试这个（也对Versandrange的定义进行了参考）。 粘贴不是范围对象的方法。

 Private Sub loopfilter() Dim thisWB As Workbook Dim filterws As Worksheet Dim howto As Worksheet Dim advfilter As Range Dim Postenws As Worksheet Dim VersandRange As Range Dim rng As Range Dim Name As String Set thisWB = ThisWorkbook Set filterws = thisWB.Sheets("Filtro") Set howto = thisWB.Sheets("How to") Set advfilter = filterws.Range("A1:AK2") Set Postenws = thisWB.Sheets("Alle gemahnten Posten (2)") Set VersandRange = howto.Range("J2", howto.Cells(Rows.Count, "j").End(xlUp)) Dim newWS As Worksheet For Each rng In VersandRange filterws.Range("AK2").value = rng.Value Application.CutCopyMode = False Postenws.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=advfilter, _ CopyToRange:=filterws.Range("A5"), _ Unique:=False Set newWS = thisWB.Sheets.Add newWS.Name = rng.Value filterws.Range("a5").CurrentRegion.Copy newWS.Range("A1") filterws.Range("a5").CurrentRegion.clearcontents Next End Sub