vba 过滤数据并将信息复制到新工作表
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/5746439/
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
Filter data and copy information to a new sheet
提问by KIA
I have a list of codes in B18 up to col AC.
我有一个 B18 到 col AC 的代码列表。
Rows 13,15 and 17 are always blank and are a part of the heading.
第 13,15 和 17 行始终为空白，是标题的一部分。
B C D E F G H
12 Codes Desc AP TP CP DP LP
13
14 TEP Q1 PR1 Q1 LT LR1
15
16 ABC xx xx xx xx xx xx
17
18 ab3 xx xx xx xx xx xx
19 ab4 xx xx xx xx xx xx
20 ab5 xx xx xx xx xx xx
21 bd2 xx xx xx xx xx xx
22 bd3 xx xx xx xx xx xx
23 bd4 xx xx xx xx xx xx
24 bd4 xx xx xx xx xx xx
25 bd6 xx xx xx xx xx xx
26 bd7 xx xx xx xx xx xx
27 bd7 xx xx xx xx xx xx
28 bd9 xx xx xx xx xx xx
In a separate codes sheet, I have a list of codes for look up
在单独的代码表中，我有一个代码列表供查找
Codes
ab3
bd4
I want to filter on the codes above and the result on a new sheet:
我想过滤上面的代码和新工作表上的结果：
B C D E F G
1 Codes Desc AP TP CP DP
2
3 TEP Q1 PR1 Q1 LT LR1
4
5 ABC xx xx xx xx xx xx
6
7 ab3 xx xx xx xx xx xx
8 bd4 xx xx xx xx xx xx
9 bd4 xx xx xx xx xx xx
回答by Jean-Fran?ois Corbett
This will do the trick. Rename the sheets and redefine the ranges as appropriate.
这将解决问题。重命名工作表并根据需要重新定义范围。
Option Explicit
Sub CopyRowsThatHaveTheRightCode()
' Assuming:
' Sheet1 is source sheet
' Sheet3 is destination sheet
' Codes are placed in Sheet2, starting at A2.
Dim iSourceRow As Long
Dim iDestinationRow As Long
Dim iCode As Long
Dim varCodes As Variant
Dim booCopyThisRow As Boolean
' Copy headers (assuming you want this)
Worksheets("Sheet1").Range("B12:AC16").Copy _
Destination:=Worksheets("Sheet3").Range("B12:AC16")
' Get the pass codes
varCodes = Worksheets("Sheet2").Range("A2").Resize(2, 1)
' Or wherever your codes are.
' Loop through all rows in source sheet
iDestinationRow = 0
For iSourceRow = 1 To 11 ' or however many rows you have
booCopyThisRow = False
For iCode = LBound(varCodes, 1) To UBound(varCodes, 1)
If varCodes(iCode, 1) _
= Worksheets("Sheet1").Range("B18").Cells(iSourceRow, 1) Then
' Code matches.
booCopyThisRow = True
Exit For
End If
Next iCode
If booCopyThisRow = True Then
' Copy into next available destination row.
iDestinationRow = iDestinationRow + 1
Worksheets("Sheet1").Range("B18").Cells(iSourceRow, 1).Resize(1, 28).Copy _
Destination:=Worksheets("Sheet3").Range("B18").Cells(iDestinationRow, 1)
End If
Next iSourceRow
End Sub
