使用 VBA 将过滤后的数据复制到另一个工作表
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/39121960/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Copy filtered data to another sheet using VBA
提问by Ananya Pandey
I have two sheets. One has the complete data and the other is based on the filter applied on the first sheet.
我有两张床单。一个具有完整的数据，另一个基于应用于第一张纸的过滤器。
Name of the data sheet : Data
Name of the filtered Sheet : Hoky
数据表Data
名称： 过滤表名称：Hoky
I am just taking a small portion of data for simplicity. MY objective is to copy the data from Data Sheet, based on the filter. I have a macro which somehow works but its hard-coded and is a recorded macro.
为简单起见，我只取了一小部分数据。我的目标是根据过滤器从数据表中复制数据。我有一个宏，它以某种方式工作，但它是硬编码的，是一个录制的宏。
My problems are:
我的问题是：
- The number of rows is different everytime. (manual effort)
- Columns are not in order.
- 行数每次都不一样。（人工努力）
- 列不按顺序。
Sub TESTTHIS()
'
' TESTTHIS Macro
'
'FILTER
Range("F2").Select
Selection.AutoFilter
ActiveSheet.Range("$B:$F").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
回答by Arpan Saini
Best way of doing it
最好的方法
Below code is to copy the visible data in DBExtract sheet, and paste it into duplicateRecords sheet, with only filtered values. Range selected by me is the maximum range that can be occupied by my data. You can change it as per your need.
下面的代码是复制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
回答by Marek
When i need to copy data from filtered table i use range.SpecialCells(xlCellTypeVisible).copy. Where the range is range of all data (without a filter).
当我需要从过滤表中复制数据时，我使用 range.SpecialCells(xlCellTypeVisible).copy。其中范围是所有数据的范围（没有过滤器）。
Example:
例子：
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
回答by Rémi
I suggest you do it a different way.
我建议你换一种方式。
In the following code I set as a Rangethe column with the sports name F and loop through each cellof it, check if it is "hockey" and if yes I insert the values in the other sheet one by one, by using Offset.
在下面的代码中，我将Range运动名称设置为F 的列，并循环遍历它的每个单元格，检查它是否是“曲棍球”，如果是，则使用Offset将值一一插入另一张纸中。
I do not think it is very complicated and even if you are just learning VBA, you should probably be able to understand every step. Please let me know if you need some clarification
我不认为它很复杂，即使您只是学习 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
