Question

我在下面的代码帮助我复制过滤后的值并粘贴到不同的工作表。它总是停在苹果...（Apple结果看起来很好）并弹出运行时错误＆＃39; 1004＆＃39;应用程序定义或对象定义的错误..

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

将以下两个程序复制到同一模块中，并使用您的条件更新 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

它也会重复Bananas，并且它会尝试在Sheet1上选择Range（“A1”），但活动工作表是Apple（或Banana），因此要解决您需要添加的问题这一行：

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

复制过滤后的值并粘贴到不同的工作表

2 个答案: