如何通過Excel VBA返回符合設置條件的特定行

Question

我有此數據，並且正在跟蹤缺陷代碼的連續和多次出現。
連續缺陷代碼是指連續出現在同一區域和同一行下的那些缺陷代碼。
那些出現3次或多次（即使不是連續的）缺陷代碼的倍數
在同一區域和同一線下。

Area    Line    Lot #           Date              Code  Description
Assy    Line1   LOT000000001    10/3/2013 13:31   5c    Vibration fail
Assy    Line12  LOT000000002    10/3/2013 13:25   5g    Key Malfunction
Labl    Line2   LOT000000003    10/3/2013 13:08   5a    No charge
Dice    Line1   LOT000000004    10/3/2013 13:03   5b    System Fail
Dice    Line2   LOT000000005    10/3/2013 13:09   3j    Sofwware fail
Dice    Line3   LOT000000006    10/3/2013 13:29   5d    No display
Circ    Line1   LOT000000007    10/3/2013 13:25   3n    Short
Circ    Line1   LOT000000008    10/3/2013 13:38   3n    Short
Circ    Line10  LOT000000009    10/3/2013 13:26   3n    Short
Circ    Line12  LOT000000010    10/3/2013 13:30   3n    Short
Circ    Line2   LOT000000011    10/3/2013 13:02   3n    Short
Circ    Line3   LOT000000012    10/3/2013 13:15   3n    Short
Circ    Line7   LOT000000013    10/3/2013 13:24   3n    Short
Circ    LineA   LOT000000014    10/3/2013 13:10   3o    Open
Circ    LineA   LOT000000015    10/3/2013 13:14   3n    Short
Circ    LineA   LOT000000016    10/3/2013 13:46   3c    High Res
Circ    LineA   LOT000000017    10/3/2013 13:47   3n    Short
Circ    LineA   LOT000000018    10/3/2013 13:50   3o    Open
Circ    LineA   LOT000000019    10/3/2013 13:51   3n    Short
Circ    LineA   LOT000000020    10/3/2013 13:55   3b    Low Res
OSTS    Line1   LOT000000021    10/3/2013 13:48   3b    Low Res
OSTS    Line1   LOT000000022    10/3/2013 13:50   3f    No Trace
OSTS    Line11  LOT000000023    10/3/2013 13:06   3a    No Signal
OSTS    Line2   LOT000000024    10/3/2013 13:24   3a    No Signal

在這種情況下，我的預期結果將是：

Circ    Line1   LOT000000007    10/3/2013 13:25   3n    Short
Circ    Line1   LOT000000008    10/3/2013 13:38   3n    Short

對於連續出現。

這是多次出現。

Circ    LineA   LOT000000015    10/3/2013 13:14   3n    Short
Circ    LineA   LOT000000017    10/3/2013 13:47   3n    Short
Circ    LineA   LOT000000019    10/3/2013 13:51   3n    Short

所以原始數據在Sheet1上，我希望結果在Sheet2中以相同的標題傳輸。
我所做的是將原始數據傳遞到數組中，然后對其進行遍歷。
我沒有得到想要的東西。 代碼很長，所以我沒有去張貼。

而且我認為制作新代碼比調試我的代碼容易。
任何幫助都感激不盡。 提前致謝。
如果仍有問題，請開除。

Answer 1

I2公式= =A2&B2&G2
J2公式= =COUNTIF($I$2:$I$25,I2)
K2公式= =I2=I3
L2公式= =IF(OR(K2,J2>=3,K1),"Copy","Do not copy")

過濾column L的數據並復制到所需的工作表。

Answer 2

我也贊成為此使用公式，而我在您的帖子評論中給出的屏幕截圖是使用公式得出的。 但是，由於您需要VBA代碼，因此就在這里。

假設您的工作表看起來像這樣

邏輯：

1. 查找Sheet1的最后一行
2. 在Col H中插入公式=A2&B2&D2&F2
3. 在第I行中插入公式=IF(H2=H3,"YES",IF(H2=H1,"YES",""))

4. 在Col J中插入公式=IF(AND(I2="",COUNTIF(H:H,H2)>2),"YES" & H2,"")

   • 實現這一目標

   

5. 接下來創建2張紙進行輸出。 讓我們將連續記錄輸出到Consecutive表，將多條記錄輸出到Multiple表

6. 將“ Col I過濾為“ Yes然后將它們移至Consecutive表
7. 過濾Col J中的Non Blanks並將其移動到Multiple張紙上
8. 根據Col J對Multiple張工作表中的數據進行排序
9. 從所有工作表中刪除H:J列

碼：

Option Explicit

Sub Sample()
    Dim ws As Worksheet, wsConsc As Worksheet, wsMulti As Worksheet
    Dim lRow As Long

    '~~> Change this to the releavnt sheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

    '~~> To create Consecutive and Multi sheets, delete existing ones if appl
    On Error Resume Next
    Application.DisplayAlerts = False
    ThisWorkbook.Sheets("Consecutive").Delete
    ThisWorkbook.Sheets("Multi").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0

    '~~> Create new sheets for output
    Set wsConsc = ThisWorkbook.Sheets.Add: wsConsc.Name = "Consecutive"
    Set wsMulti = ThisWorkbook.Sheets.Add: wsMulti.Name = "Multi"

    With ws
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row

        .Columns("H:J").ClearContents

        .Range("H2:H" & lRow).Formula = "=A2&B2&D2&F2"
        .Range("I2:I" & lRow).Formula = "=IF(H2=H3,""YES"",IF(H2=H1,""YES"",""""))"
        .Range("J2:J" & lRow).Formula = "=IF(AND(I2="""",COUNTIF(H:H,H2)>2),""YES"" & H2,"""")"

        .Range("H2:J" & lRow).Value = .Range("H2:J" & lRow).Value

        .AutoFilterMode = False

        With .Range("I1:I" & lRow)
            .AutoFilter Field:=1, Criteria1:="=YES"
            .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
            wsConsc.Rows(1)
        End With

        .AutoFilterMode = False

        With .Range("J1:J" & lRow)
            .AutoFilter Field:=1, Criteria1:="<>"
            .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
            wsMulti.Rows(1)

            wsMulti.Columns("A:J").Sort Key1:=wsMulti.Range("J2"), Order1:=xlAscending, Header:=xlYes, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
        End With

        .AutoFilterMode = False

        .Columns("H:J").ClearContents
        wsConsc.Columns("H:J").ClearContents
        wsMulti.Columns("H:J").ClearContents
    End With
End Sub

輸出：