筛选工作表，然后使用VBA将选择内容复制到新工作表上

Question

尝试筛选，然后在循环中复制筛选的单元格，得到错误消息“工作表类的粘贴方法失败”。

似乎失败了，因为我正在使用循环，我尝试了特殊的其他粘贴方法，但这似乎不起作用，请帮助

Sub Split()

Dim wsYes As Worksheet
Set wsYes = Worksheets("YES")

With wsYes

    Dim myRange As Range
    Set myRange = .Range("A2", .Range("A2").End(xlDown))

    myRange.Copy .Cells(1, .Columns.Count) 'copy to far right column
    .Cells(1, .Columns.Count).Resize(myRange.Rows.Count, 1).RemoveDuplicates 1, xlNo

    Set myRange = .Range(.Cells(1, .Columns.Count), .Cells(1, .Columns.Count).End(xlDown))

    For Each MyCell In myRange



        Dim sName As String
        sName = UCase(MyCell.Value)


        Range("A1").Select
       Selection.AutoFilter
           ActiveSheet.Range("$A$1:$B$9").AutoFilter Field:=1, Criteria1:= _
        sName

        Range("B:B").Select
        Selection.Copy

        Dim wsNew As Worksheet
        Set wsNew = Sheets.Add(After:=Sheets(Sheets.Count)) ' creates a new worksheet
        wsYes.Range("B:B").Copy
        With wsNew
            .Name = sName
            .Range("A1").Value = "Column Name"
            .Range("A1").Font.Bold = True
            .Range("A2").Value = sName
            .Range("B1").Select
            ActiveSheet.Paste


        End With

    Next MyCell

    myRange.Clear

End With



End Sub

提前致谢

Answer 1

您需要将“复制”和“粘贴”在一起，而不要在wsNew工作表上进行其他操作

Sub Split()

Dim wsYes As Worksheet
Set wsYes = Worksheets("YES")

With wsYes

    Dim myRange As Range
    Set myRange = .Range("A2", .Range("A2").End(xlDown))

    myRange.Copy .Cells(1, .Columns.Count) 'copy to far right column
    .Cells(1, .Columns.Count).Resize(myRange.Rows.Count, 1).RemoveDuplicates 1, xlNo

    Set myRange = .Range(.Cells(1, .Columns.Count), .Cells(1, .Columns.Count).End(xlDown))

    For Each MyCell In myRange

        Dim sName As String
        sName = UCase(MyCell.Value)

        wsYes.Select
        Range("A1").Select
        Selection.AutoFilter
        ActiveSheet.Range("$A$1:$B$9").AutoFilter Field:=1, Criteria1:=sName

        wsYes.Range("B:B").Select
        Selection.Copy

        Dim wsNew As Worksheet
        Set wsNew = Sheets.Add(After:=Sheets(Sheets.Count)) ' creates a new worksheet

        With wsNew
            .Name = sName
            .Range("A1").Value = "Column Name"
            .Range("A1").Font.Bold = True
            .Range("A2").Value = sName

            ' moved copy and paste tasks one after the other
             wsYes.Range("B:B").Copy
            .Columns("B:B").Select
             ActiveSheet.Paste
        End With

    Next MyCell
    myRange.Clear

End With

End Sub

Answer 2

试试这个代码。

Sub Split()

Dim MyCell As Range

Dim wsYes As Worksheet
Set wsYes = Worksheets("YES")

With wsYes

    Dim myRange As Range
    Set myRange = .Range("A2", .Range("A2").End(xlDown))

    myRange.Copy .Cells(1, .Columns.Count) 'copy to far right column
    .Cells(1, .Columns.Count).Resize(myRange.Rows.Count, 1).RemoveDuplicates 1, xlNo

    Set myRange = .Range(.Cells(1, .Columns.Count), .Cells(1, .Columns.Count).End(xlDown))

    For Each MyCell In myRange



        Dim sName As String
        sName = UCase(MyCell.Value)

        With wsYes
            .Range("A1").Select
            .Selection.AutoFilter
            .Range("$A$1:$B$9").AutoFilter Field:=1, Criteria1:=sName

            Dim wsNew As Worksheet
            Set wsNew = Sheets.Add(After:=Sheets(Sheets.Count)) ' creates a new worksheet
        End With
        With wsNew
            .Name = sName
            .Range("A1").Value = "Column Name"
            .Range("A1").Font.Bold = True
            .Range("A2").Value = sName
            .Range("B1").Select
            wsYes.Range("B:B").Copy
            ActiveSheet.Paste


        End With

    Next MyCell

    myRange.Clear

End With



End Sub

在将A1设为粗体后，似乎正在清除缓冲区，因此您没有任何复制。