Question

我想在1个字段的表上应用过滤器，然后将值复制并粘贴到另一个工作簿。我使用下面的代码。但它不起作用。

由于数据量很大，excel突然停止响应。如何更改代码。帮帮我

sub createfilter()

Dim FiltRng As Range Dim RngArea As Range

Sheet2.ListObjects("DataTable").Range.AutoFilter Field:=12, Criteria1:="DE", Operator:=xlFilterValues

For Each RngArea In Sheet2.ListObjects("DataTable").Range.SpecialCells(xlCellTypeVisible).Rows

If RngArea.Row > 1 Then
    If Not FiltRng Is Nothing Then
        Set FiltRng = Application.Union(FiltRng, RngArea)
    Else
        Set FiltRng = RngArea
    End If End If

Next RngArea

If Not FiltRng Is Nothing Then
    FiltRng.Copy
    Windows("Land-DE.xlsx").Activate
    Sheets("Overall view").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False End If

End sub

Answer 1

这不使用复制和粘贴（不是传输数据的最佳方式），但应该做你想做的事情

Sub createfilter()
    Dim Results As Variant, tmp As Variant
    Dim i As Long, j As Long
    Dim CriteriaCol As Long, ResultCount As Long
    Dim Criteria As String

    Criteria = "DE"
    CriteriaCol = 12

    With Sheet2.ListObjects("DataTable")
        tmp = .DataBodyRange
    End With

    ReDim Results(LBound(tmp, 2) To UBound(tmp, 2), LBound(tmp, 1) To UBound(tmp, 1))
    For i = LBound(tmp, 1) To UBound(tmp, 1)
        If UCase(tmp(i, CriteriaCol)) = UCase(Criteria) Then
            ResultCount = ResultCount + 1
            j = LBound(tmp, 2) - 1
            Do
                j = j + 1
                Results(j, ResultCount) = tmp(i, j)
            Loop Until j = UBound(tmp, 2)
        End If
    Next i
    ReDim Preserve Results(LBound(Results, 1) To UBound(Results, 1), LBound(Results, 1) To ResultCount)
    With Workbooks("Land-DE.xlsx").Sheets("Overall view")
        .Cells(1, 1).Resize(UBound(Results, 2), UBound(Results, 1)) = Application.Transpose(Results)
    End With
End Sub

Answer 2

默认情况下，仅复制未过滤的行：

Sub createfilter()

    Dim r As Range : Set r = Sheet2.Range("DataTable")

    r.AutoFilter 12, "DE", xlFilterValues

    If r.Height Then r.Copy ['[Land-DE.xlsx]Overall view'!A1]

End Sub

使用PasteSpecial更新（未经测试）：

Sub CreateFilter()
    With Sheet2.Range("DataTable")

        .AutoFilter 12, "DE", xlFilterValues

        If .Height Then .Copy Else Exit Sub 
    End With

    With ['[Land-DE.xlsx]Overall view'!A1]
        .PasteSpecial xlPasteAllUsingSourceTheme
        .PasteSpecial xlPasteValues
    End With
End Sub

Answer 3

您也可以只复制过滤后的范围。

    Sub Copy_FilteredRange()
    Dim FiltRng As Range, RngArea As Range, wb As Workbook, ws As Worksheet, rng As Range

    Set wb = Workbooks("Land-DE.xlsx")
    Set ws = wb.Sheets("Overall view")
    Set rng = ws.Range("A1")

    Application.ScreenUpdating = 0
    Sheet2.ListObjects("DataTable").Range.AutoFilter Field:=12, Criteria1:="DE", Operator:=xlFilterValues
    Sheet2.AutoFilter.Range.Offset(1).Copy
    rng.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    Sheet2.ListObjects("DataTable").AutoFilter.ShowAllData
End Sub

过滤表后复制/粘贴到不同的工作簿

3 个答案: