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_或S_ZS_之后的字符链相同，我必须检查B列。如果它们是相同的。我必须删除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

非VBA解决方案：插入新列C. 假设数据从第1行开始，在C1中输入：

=CONCATENATE(A1,MID(B1,5,LEN(B1)-4))

将公式复制到C列。然后使用关键字C列的删除重复项。

Answer 2

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

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

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

基于重复单元格和第二列（VBA）的内容删除行

2 个答案: