Copy/Pasting to different workbook after filtering

问题:

I would like to apply filter on a table on 1 field, then copy and paste the values to another workbook.I used a code below. But its not working.

Due to to big data the excel suddenly stops responding. How to change the code. Help me

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

回答1:

This doesn't use Copy and Paste (not the best way to transfer data) but should do what you want

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

回答2:

Only the non-filtered rows are copied by default:

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

---

Update with PasteSpecial (not tested) :

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

回答3:

You can also just copy the filtered range.

    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