vba - 根据重复单元格和第二列的内容删除行 (VBA)

Question

我在删除重复行时遇到了一些麻烦，因为我必须这样做是一种困难。让我解释。

这就是我所拥有的(实际上我有超过 90,000 行!)

+-----------+------------------+
|    Ref    |       Sup        |
+-----------+------------------+
| 10000-001 | S_LA_LLZ_INOR    |
| 10000-001 | S_LA_RADAR_STNFN |
| 10000-001 | S_LA_VOR_LRO     |
| 10000-001 | S_LA_DME_LRO     |
| 10000-001 | S_LA_DME_INOR    |
| 1000-001  | S_LA_GP_INOR     |
| 1000-001  | S_LA_LLZ_ITF     |
| 1000-001  | S_ZS_LLZ_ITF     |
| 1000-002  | S_LA_GP_INOR     |
| 1000-002  | S_LA_LLZ_ITF     |
+-----------+------------------+

我要做的是在 A 列中搜索重复项。如果 S_LA_ 之后的字符链，我必须检查 B 列。或 S_ZS_是相同的。如果他们是一样的。我必须删除带有 S_LA_ 的行

因此，在上面的行中，我必须删除带有 1000-001|S_LA_LLZ_ITF 的行.

我已经写了一个代码。它可以工作，但是在处理 10,000 多行时速度非常慢。

Dim LastRowcheck As Long
Dim str1 As String
Dim str2 As String
Dim str3 As String
Dim str4 As String
Dim str5 As String
Dim str6 As String
Dim prueba As Integer
Dim prueba1 As Integer
Dim n1 As Long
Dim n3 As Long
Dim colNum As Integer
Dim colNum1 As Integer
Dim iCntr As Long

colNum = WorksheetFunction.Match("Ref", ActiveSheet.Range("1:1"), 0)
colNum1 = WorksheetFunction.Match("Sup",ActiveSheet.Range("1:1"), 0)

With ActiveSheet
  LastRowcheck = .Range("A" & .Rows.Count).End(xlUp).Row
  For n1 = 2 To LastRowcheck
      str1 = Cells(n1, colNum).Value
      For n3 = n1 + 1 To LastRowcheck + 1
          str2 = Cells(n3, colNum).Value
          prueba = StrComp(num1, num2)
          If prueba = 0 Then
              str3 = Cells(n1, colNum1).Value
              str4 = Cells(n3, colNum1).Value
              str5 = Right(str3, Len(str3) - 5)
              str6 = Right(str4, Len(str4) - 5)
              prueba1 = StrComp(str5, str6)
                  If prueba1 = 0 Then
                      If StrComp(num3, num4) = 1 Then
                          Cells(n3, colNum).Interior.ColorIndex = 3
                      ElseIf StrComp(num3, num4) = -1 Then
                          Cells(n1, colNum).Interior.ColorIndex = 3
                      End If
                  End If
              End If
          Next n3
      Next n1

  For iCntr = LastRowcheck To 2 Step -1
      If Cells(iCntr, colNum).Interior.ColorIndex = 3 Then
          Rows(iCntr).Delete
      End If
  Next iCntr
End With

如果您能给我任何帮助或指导，我将不胜感激。

Answer 1

我相信这几乎就在那里 - 确保在运行之前备份您的数据，因为这会覆盖数据

Sub test()
Dim IN_arr()
Dim OUT_arr()

IN_arr = ActiveSheet.UsedRange.Value2
Count = 1
ReDim OUT_arr(UBound(IN_arr, 2) - 1, Count)
Found = 1

For i = 1 To UBound(IN_arr, 1)
    Found = 1
    For c = 1 To UBound(IN_arr, 1)
        Comp1 = Right(IN_arr(i, 2), Len(IN_arr(i, 2)) - InStr(1, IN_arr(i, 2), "S_LA") - 3) 'Compare last section
        Comp2 = Right(IN_arr(c, 2), Len(IN_arr(c, 2)) - InStr(1, IN_arr(c, 2), "S_ZS") - 3)

        Comp3 = IN_arr(i, 1) 'Compare first section
        Comp4 = IN_arr(c, 1)

        If Comp1 = Comp2 And i <> c And Comp3 = Comp4 Then
            Found = 0
        End If
    Next
    If Found = 0 Then
        'do not keep row
    Else
        'keep row
        If OUT_arr(UBound(IN_arr, 2) - 1, Count - 1) <> "" Then
            Count = Count + 1
            ReDim Preserve OUT_arr(UBound(IN_arr, 2) - 1, Count)
        End If

        For cols = 0 To UBound(IN_arr, 2) - 1
            OUT_arr(cols, Count - 1) = IN_arr(i, cols + 1)
        Next


    End If
Next

ActiveSheet.UsedRange.ClearContents
ActiveSheet.Range("A1").Resize(Count, UBound(OUT_arr, 1) + 1).Value = Application.Transpose(OUT_arr)

End Sub

请注意对代码进行了一些小的更改