使用 VBA 将过滤后的数据复制到另一个工作表

Posted 2023-02-27

【中文标题】使用 VBA 将过滤后的数据复制到另一个工作表

【英文标题】：Copy filtered data to another sheet using VBA

【发布时间】：2016-12-31 12:13:24

【问题描述】：

我有两张床单。一个具有完整的数据，另一个基于第一张纸上应用的过滤器。

数据表名称：Data 过滤后的工作表名称：Hoky

为了简单起见，我只提取了一小部分数据。我的目标是根据过滤器从数据表中复制数据。我有一个宏，它以某种方式工作，但它是硬编码的，并且是一个录制的宏。

我的问题是：

行数每次都不一样。 （手动） 列不按顺序排列。

Sub TESTTHIS()
'
' TESTTHIS Macro
'
'FILTER
Range("F2").Select
Selection.AutoFilter
ActiveSheet.Range("$B$2:$F$12").AutoFilter Field:=5, Criteria1:="hockey"

'Data Selection and Copy
Range("C3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Hockey").Select
Range("E3").Select
ActiveSheet.Paste

Sheets("Data").Select
Range("D3").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Hockey").Select
Range("D3").Select
ActiveSheet.Paste

Sheets("Data").Select
Range("E3").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Hockey").Select
Range("C3").Select
ActiveSheet.Paste

End Sub

【参考方案1】：

它需要是 .Row.count 而不是 Row.Number？

这就是我使用的，它工作正常 子 TransfersToCleared() 暗淡为工作表 将 LastRow 变暗 Set ws = Application.Worksheets("Export(2)") '数据源 LastRow = Range("A" & Rows.Count).End(xlUp).Row ws.Range("A2:AB" & LastRow).SpecialCells(xlCellTypeVisible).Copy

【参考方案2】：

最好的方法

下面的代码是复制 DBExtract 表中的可见数据，并将其粘贴到 duplicateRecords 表中，只有过滤值。我选择的范围是我的数据可以占用的最大范围。您可以根据需要更改它。

  Sub selectVisibleRange()

    Dim DbExtract, DuplicateRecords As Worksheet
    Set DbExtract = ThisWorkbook.Sheets("Export Worksheet")
    Set DuplicateRecords = ThisWorkbook.Sheets("DuplicateRecords")

    DbExtract.Range("A1:BF9999").SpecialCells(xlCellTypeVisible).Copy
    DuplicateRecords.Cells(1, 1).PasteSpecial


    End Sub

【讨论】：

SpecialCells(xlCellTypeVisible) 正是我想要的。谢谢！

【参考方案3】：

当我需要从过滤表中复制数据时，我使用 range.SpecialCells(xlCellTypeVisible).copy。其中范围是所有数据的范围（没有过滤器）。

例子：

Sub copy()
     'source worksheet
     dim ws as Worksheet
     set ws = Application.Worksheets("Data")' set you source worksheet here
     dim data_end_row_number as Integer
     data_end_row_number = ws.Range("B3").End(XlDown).Row.Number
    'enable filter
    ws.Range("B2:F2").AutoFilter Field:=2, Criteria1:="hockey", VisibleDropDown:=True
    ws.Range("B3:F" & data_end_row_number).SpecialCells(xlCellTypeVisible).Copy
    Application.Worksheets("Hoky").Range("B3").Paste
    'You have to add headers to Hoky worksheet
end sub

【讨论】：

你能写一个例子（完整的代码），以便我可以将它应用到我的工作表上。

@AnanyaPandey 这不是“免费代码编写服务”。请参阅How to Ask 和help center。

恕我直言，先生，我不是要求免费服务，我试过我失败了，在这里寻求帮助我正在学习，谢谢您的宝贵意见。

【参考方案4】：

我建议你换一种方式。

在下面的代码中，我将运动名称 F 和 loop through each cell 的列设置为 Range，检查它是否是“曲棍球”，如果是，我将值一一插入另一张表中，通过使用Offset。

我认为这不是很复杂，即使你只是学习 VBA，你应该能够理解每一步。如果您需要澄清，请告诉我

Sub TestThat()

'Declare the variables
Dim DataSh As Worksheet
Dim HokySh As Worksheet
Dim SportsRange As Range
Dim rCell As Range
Dim i As Long

'Set the variables
Set DataSh = ThisWorkbook.Sheets("Data")
Set HokySh = ThisWorkbook.Sheets("Hoky")

Set SportsRange = DataSh.Range(DataSh.Cells(3, 6), DataSh.Cells(Rows.Count, 6).End(xlUp))
    'I went from the cell row3/column6 (or F3) and go down until the last non empty cell

    i = 2

    For Each rCell In SportsRange 'loop through each cell in the range

        If rCell = "hockey" Then 'check if the cell is equal to "hockey"

            i = i + 1                                'Row number (+1 everytime I found another "hockey")
            HokySh.Cells(i, 2) = i - 2               'S No.
            HokySh.Cells(i, 3) = rCell.Offset(0, -1) 'School
            HokySh.Cells(i, 4) = rCell.Offset(0, -2) 'Background
            HokySh.Cells(i, 5) = rCell.Offset(0, -3) 'Age

        End If

    Next rCell

End Sub

【讨论】：

效果很好。谢谢。我明白了，尽管我必须更多地了解偏移函数。

这是一个非常耗时的过程，需要花费大量时间来读取每一行并将其复制到另一个工作表，当您有数千条记录的数据时工作表会挂起