如何通过excel VBA返回满足设置条件的特定行

我有这些数据，我正在跟踪连续和多次出现的缺陷代码。
连续缺陷代码是指连续出现在同一区域和线下的缺陷代码。
“多个”是指在同一区域和行下出现3次或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 区域线地块#日期代码说明 组装线1 LOT0000000001 10/3/2013 13:31 5c振动故障 组装线12 LOT0000000002 10/3/2013 13:25 5g钥匙故障 标签行2 LOT0000000003 10/3/2013 13:08 5a免费 Dice Line1 LOT0000000004 10/3/2013 13:03 5b系统故障 Dice Line2 LOT0000000005 10/3/2013 13:09 3j软件失败 骰子线3 LOT0000000006 10/3/2013 13:29 5d无显示 Circ Line1 LOT0000000007 10/3/2013 13:25 3n短 Circ Line1 LOT0000000008 10/3/2013 13:38 3n短 Circ Line10 LOT0000000009 10/3/2013 13:26 3n短 Circ Line12 LOT0000000010 10/3/2013 13:30 3n短 Circ Line2 LOT0000000011 10/3/2013 13:02 3n短 Circ Line3 LOT0000000012 10/3/2013 13:15 3n短 Circ Line7 LOT0000000013 10/3/2013 13:24 3n短 Circ LineA LOT0000000014 10/3/2013 13:10 3o开放 2013年3月10日13时14分 Circ LineA LOT0000000016 10/3/2013 13:46 3c高分辨率 Circ LineA LOT0000000017 10/3/2013 13:47 3n短 2013年3月10日13时50分开放 Circ LineA LOT0000000019 10/3/2013 13:51 3n短 Circ LineA LOT0000000020 10/3/2013 13:55 3b低分辨率 OSTS Line1 LOT0000000021 10/3/2013 13:48 3b低分辨率 OSTS Line1 LOT0000000022 10/3/2013 13:50 3f无跟踪 OSTS线路11 LOT0000000023 10/3/2013 13:06 3a无信号 OSTS Line2 LOT0000000024 10/3/2013 13:24 3a无信号 在这种情况下，我的预期结果是：

Circ Line1 LOT000000007 10/3/2013 13:25 3n Short Circ Line1 LOT000000008 10/3/2013 13:38 3n Short Circ Line1 LOT0000000007 10/3/2013 13:25 3n短 Circ Line1 LOT0000000008 10/3/2013 13:38 3n短 对于连续发生的事件

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 这是多次出现的原因

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 2013年3月10日13时14分 Circ LineA LOT0000000017 10/3/2013 13:47 3n短 Circ LineA LOT0000000019 10/3/2013 13:51 3n短 因此，原始数据在Sheet1上，我希望结果以相同的标题传输到Sheet2中。
我所做的是将原始数据传递到数组中，然后对其进行迭代。
但是我没有得到我想要的。代码很长，所以我没有费心发布

我认为编写新代码比调试我的代码更容易。
任何帮助都将不胜感激。提前感谢。

---

如果你还有问题，就直接提问。

公式在

I2

=

=A2&B2&G2

J2中的公式
=
=COUNTIF（$I$2:$I$25，I2）


K2中的公式
=
=I2=I3


L2
=
=IF（或（K2，J2>=3，K1），“复制”、“不复制”中的公式


过滤
列L中的数据
，并复制到所需的工作表中

我也赞成使用公式来解决这个问题，我在你的帖子评论中给出的屏幕截图是使用公式推导出来的。但是，因为您需要VBA代码，所以它就在这里

比如说，你的床单看起来像这样


逻辑：

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

查找表1的最后一行
在H列中插入公式
=A2&B2&D2&F2
在列I中插入公式
=IF（H2=H3，“是”，IF（H2=H1，“是”），
在J列中插入公式
=IF（和（I2=），COUNTIF（H:H，H2）>2），“YES”和“H2””


实现这一目标的目标


接下来创建两张图纸用于输出。让我们将连续记录输出到
连续
工作表，并将多个记录输出到
多个
工作表

过滤
Col I
中的
Yes
并将其移动到
连续的
工作表中
过滤
列J
中的
非空白
，并将其移动到
多个
工作表中
根据列J对
多个
表中的数据进行排序

从所有工作表中删除列
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

选项显式
子样本（）
将ws作为工作表、wsConsc作为工作表、wsMulti作为工作表
暗淡的光线和长的一样
“~~>将此更改为相关工作表
设置ws=ThisWorkbook.Sheets（“Sheet1”）
“~~>若要创建连续和多张图纸，请删除现有图纸（如果适用）
出错时继续下一步
Application.DisplayAlerts=False
此工作簿。工作表（“连续”）。删除
此工作簿。工作表（“多”）。删除
Application.DisplayAlerts=True
错误转到0
“~~>为输出创建新图纸
设置wsConsc=thiswoolk.Sheets.Add:wsConsc.Name=“连续”
设置wsMulti=thiswoolk.Sheets.Add:wsMulti.Name=“Multi”
与ws
lRow=.Range（“A”&.Rows.Count）.End（xlUp）.Row
.列（“H:J”）.ClearContents
.范围（“H2:H”和lRow）。公式=“=A2&B2&D2&F2”
.Range（“I2:I”和lRow）.Formula=“=IF（H2=H3”，“YES”，IF（H2=H1”，“YES”））
.Range（“J2:J”和lRow）。公式=“=IF（和（I2）”，COUNTIF（H:H，H2）>2），“YES”和“H2”
.Range（“H2:J”和lRow）.Value=.Range（“H2:J”和lRow）.Value
.AutoFilterMode=False
带.Range（“I1:I”和lRow）
.自动筛选字段：=1，标准1:==是
.Offset（1，0）.特殊单元格（xlCellTypeVisible）.EntireRow.Copy_
wsConsc.行（1）
以
.AutoFilterMode=False
带.Range（“J1:J”和lRow）
.自动筛选字段：=1，标准1:=“”
.Offset（1，0）.特殊单元格（xlCellTypeVisible）.EntireRow.Copy_
wsMulti.Rows（1）
wsMulti.Columns（“A:J”）.So