过滤数据并将信息复制到新的工作表中
|
我有B18直到col AC的代码列表。
第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
Codes
ab3
bd4
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
没有找到相关结果
已邀请:
1 个回复
淘圃跺枯替
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