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加粗后，它正在清除缓冲区，因此您没有复制任何内容。

使用VBA过滤工作表，并将选择复制到新工作表上

2 个答案: