从高级过滤器粘贴

Question

我被困在一条线上，不知道如何解决这个错误。我通过使用高级过滤器过滤不同的名称并将数据复制到单个工作表中来划分列表中的行，但是卡在一行上，即 Next 之前的最后一行：“newWS.Range("A1").Paste ”。我从调试中得到错误 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