Question

我在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

Answer 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

过滤数据并将信息复制到新工作表

1 个答案: