过滤表后复制/粘贴到其他工作簿 [英] Copy/Pasting to different workbook after filtering table

问题描述

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

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.

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

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

推荐答案

这不使用复制和粘贴"(这不是传输数据的最佳方法)，但是应该做您想做的事

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

这篇关于过滤表后复制/粘贴到其他工作簿的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！