Фильтровать лист и скопировать выделение на новый лист с помощью 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 смелого он очищал буфер, так что вы не скопировали ничего.