複製過濾的值並粘貼到不同的工作表

Question

我有下面的代碼可以幫助我複製過濾的值並粘貼到不同的工作表。 它總是停在蘋果......（蘋果結果看起來不錯），並彈出運行時error'1004' 應用程序定義或對象定義的錯誤..

Sub CoWFTR() 

'Filter out Apple 
    Sheet1.Range("A1:ER1").Select 
    Selection.AutoFilter Field:=11, Criteria1:=Array(_ 
     "ILOVEApple"), Operator:=xlFilterValues 

'Copy and Paste to Apple Tab 
Range(Selection, Selection.End(xlDown)).Select 
    Range(Selection, Selection.End(xlToRight)).Select 
    Selection.Copy 
    Sheets("Apple").Select 
    ActiveSheet.Paste 

Sheet1.Range("A1").Select 
Application.CutCopyMode = False 

'Clear Filter 
On Error Resume Next 
    Sheet1.ShowAllData 
On Error GoTo 0 

'Filter out Banana 
    Sheet1.Range("A1:ER1").Select 
    Selection.AutoFilter Field:=11, Criteria1:=Array(_ 
     "ILOVEBanana"), Operator:=xlFilterValues 

'Copy and Paste to Banana Tab 
Range(Selection, Selection.End(xlDown)).Select 
    Range(Selection, Selection.End(xlToRight)).Select 
    Selection.Copy 
    Sheets("Banana").Select 
    ActiveSheet.Paste 


Sheet1.Range("A1").Select 
Application.CutCopyMode = False 

'Clear Filter 
On Error Resume Next 
    Sheet1.ShowAllData 
On Error GoTo 0 

End Sub 

Answer 1

複製2個程序在同一個波紋管模塊，以及更新FILTER_ITEMS與您的標準：

Option Explicit 

Public Sub CoWFTR() 
    Const FILTER_COL As Long = 11 'K 
    Const FILTER_ITEMS As String = "ILOVEApple,ILOVEBanana" 
    Dim wsFrom As Worksheet, wsDest As Worksheet, fi As Variant, i As Long 

    Set wsFrom = Sheet1 '<--- Update this 

    fi = Split(FILTER_ITEMS, ",") 
    Application.ScreenUpdating = False 
    For i = 0 To UBound(fi) 
     Set wsDest = CheckNamedSheet(fi(i)) 
     With wsFrom.UsedRange 
      .AutoFilter Field:=11, Criteria1:="=" & fi(i), Operator:=xlFilterValues 
      .Copy 'Copy visible data 
     End With 
     With wsDest.Cells 
      .PasteSpecial xlPasteColumnWidths 
      .PasteSpecial xlPasteAll 
      Application.CutCopyMode = False 
      wsDest.Activate 
      .Cells(1, 1).Select 
     End With 
    Next 
    With wsFrom 
     .Activate 
     .Cells(1, 1).Copy 
     .UsedRange.AutoFilter 
    End With 
    Application.ScreenUpdating = True 
End Sub 

---

這種管理新牀單

Private Function CheckNamedSheet(ByVal sheetName As String) As Worksheet 
    Dim ws As Worksheet, result As Boolean, activeWS As Worksheet 

    Set activeWS = IIf(ActiveSheet.Name = sheetName, Worksheets(1), ActiveSheet) 
    For Each ws In Worksheets 
     If ws.Name = sheetName Then 
      Application.DisplayAlerts = False 
      ws.Delete 'delete sheet if it already exists 
      Application.DisplayAlerts = True 
      Exit For 
     End If 
    Next 
    Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count)) 'create a new one 
    ws.Name = sheetName 
    activeWS.Activate 
    Set CheckNamedSheet = ws 
End Function 

---

爲您的代碼，你所得到的錯誤是在這一行：

Sheet1.Range("A1").Select 

它重複了香蕉爲好，由它試圖選擇Range（「A1」的事實觸發）在Sheet1，但活動工作表是蘋果（或香蕉），所以要修復需要添加這一行的問題：

Sheet1.Activate 

這裏是你的代碼，固定：

Sub CoWFTR() 

'Filter out Apple 
    Sheet1.Range("A1:ER1").Select 
    Selection.AutoFilter Field:=11, Criteria1:=Array(_ 
     "ILOVEApple"), Operator:=xlFilterValues 

'Copy and Paste to Apple Tab 
Range(Selection, Selection.End(xlDown)).Select 
    Range(Selection, Selection.End(xlToRight)).Select 
    Selection.Copy 
    Sheets("Apple").Select 
    ActiveSheet.Paste 

Sheet1.Activate   'Fix to error 1004 
Sheet1.Range("A1").Select 
Application.CutCopyMode = False 

'Clear Filter 
On Error Resume Next 
    Sheet1.ShowAllData 
On Error GoTo 0 

'Filter out Banana 
    Sheet1.Range("A1:ER1").Select 
    Selection.AutoFilter Field:=11, Criteria1:=Array(_ 
     "ILOVEBanana"), Operator:=xlFilterValues 

'Copy and Paste to Banana Tab 
Range(Selection, Selection.End(xlDown)).Select 
    Range(Selection, Selection.End(xlToRight)).Select 
    Selection.Copy 
    Sheets("Banana").Select 
    ActiveSheet.Paste 

Sheet1.Activate   'Fix to error 1004 
Sheet1.Range("A1").Select 
Application.CutCopyMode = False 

'Clear Filter 
On Error Resume Next 
    Sheet1.ShowAllData 
On Error GoTo 0 

End Sub 

---

Answer 2

我認爲這是有用的使用xlCellTypeVisible。並使用數組。

Sub CoWFTR() 
Dim WS As Worksheet, toWs As Worksheet 
Dim rngDB As Range, rngTo As Range 
Dim vCriteria, vName, i As Integer 

    Set WS = Sheet1 
    Set toWs = Sheets("Apple") 
    Set rngDB = WS.Range("a1").CurrentRegion 

    vCriteria = Array("ILOVEApple", "ILOVEBanana") 
    vName = Array("Apple", "Banana") 

    For i = 0 To UBound(vCriteria) 
     If WS.FilterMode Then 
      WS.ShowAllData 
     End If 
     Set toWs = Sheets(vName(i)) 
     Set rngTo = toWs.Range("a" & Rows.Count).End(xlUp)(2) 

     rngDB.AutoFilter Field:=11, Criteria1:=Array(_ 
     vCriteria(i)), Operator:=xlFilterValues 
     rngDB.SpecialCells(xlCellTypeVisible).Offset(1).Copy rngTo 

    Next i 

    If WS.FilterMode Then 
     WS.ShowAllData 
    End If 

End Sub