過濾表單，並使用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大膽後，這是清除緩衝區，所以你就沒有複製。