VBA 收集行中连续的相似单元格

Question

我有一份不同产品在不同时间出现的不合格清单。我需要找出类似的问题。 我已经整理好了

现在我需要获取具有相似行的新工作表，并且在产品、不符合性和日期中具有相似的值。

为了获得它，我使用了以下代码，但不确定它是否是正确的方法：

' Look for similar non conformities >2
    Sheets.Add.Name = "Result"
    Dim wb As Workbook
    Dim ws As Worksheet, ws2 As Worksheet
    Dim CurrentRow As Long, Lastrow As Long, Lastrow2 As Long, k As Long
    
    Set wb = ActiveWorkbook
    Set ws = wb.Sheets("DuplicateRecords") 'Sheet where I have filtered result
    Set ws2 = wb.Sheets("Result") ' Resulting sheet
    CurrentRow = 2
    
    Lastrow = ws.Range("V" & Rows.Count).End(xlUp).Row
        
    For k = CurrentRow To Lastrow
        If ws.Range("G" & CurrentRow).Value2 = ws.Range("G" & CurrentRow + 1).Value2 And _
           ws.Range("V" & CurrentRow).Value2 = ws.Range("V" & CurrentRow + 1).Value2 And _
           ws.Range("T" & CurrentRow).Value2 = ws.Range("T" & CurrentRow + 1).Value2 Then
            Lastrow2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
            ws2.Range("A" & Lastrow2 + 1).Value2 = ws.Range("A" & CurrentRow).Value2
            ws2.Range("B" & Lastrow2 + 1).Value2 = ws.Range("B" & CurrentRow).Value2
            ws2.Range("C" & Lastrow2 + 1).Value2 = ws.Range("C" & CurrentRow).Value2
            ws2.Range("D" & Lastrow2 + 1).Value2 = ws.Range("D" & CurrentRow).Value2
          
        End If
        CurrentRow = CurrentRow + 1
    Next k

Answer 1

如果您有 Excel 365，您可以通过公式实现此目的：

=LET(d,Tabelle1,
u,UNIQUE(DROP(d,,1)),
cnt,HSTACK(u, BYROW(u,LAMBDA(z,
                             COUNTIFS(INDEX(d,,2),INDEX(z,,1),
                                      INDEX(d,,3),INDEX(z,,2),
                                      INDEX(d,,4),INDEX(z,3))))),
FILTER(cnt,INDEX(cnt,,4)>1))