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

删除重复行时遇到了一些麻烦，因为我必须这么做的方式很难。让我解释。根据重复的单元格和第二列的内容删除行（VBA）

这是我（其实我有超过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列的重复搜索。那么我必须检查B列，如果S_LA_或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

我希望您能给我提供任何帮助或指导。

来源

2015-06-24 Francisco Rodríguez González

如何以上述方式使用删除重复项？我无法控制哪些重复删除（或至少我不知道如何） –

@Raystafarian因为他只比较两个不同字符串的最后部分。 OP我会阅读数组的内容，就CPU时间而言，访问数据表是非常昂贵的事情，数组会大大缩短您的时间。例如将表格范围读入数组 - 处理 - 清除表格 - 读取数组返回表格 – 99moorem

听起来很有希望，但我怎么能这样做呢？ –

我相信这是几乎没有 - 确保把你的数据备份运行前asthis将覆盖数据

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

请注意对代码做了一些小修改

来源

2015-06-24 13:35:58 99moorem

谢谢，但我无法完成工作。它删除了evereything –

我对上面的代码做了一些更改。此外，代码期望Col A和Col B被排列为有问题 – 99moorem

仅仅为了我自己的好奇心，这段代码花了多长时间与原来的代码相比？ – 99moorem

非VBA溶液：插入新的列C 假设数据在第1行开始时，在C1输入：

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

复印式向下柱C.然后，使用删除重复feaure键入到C列

来源

2015-06-24 12:58:07

哇！这是有效的，但我不知道它是否删除了S_ZS_的副本或S_LA_ –

的副本。按照列B的降序对数据进行排序。这将使所有的S_ZS_高于所有的S_LA_。然后当你删除重复的第一个（S_ZS_）将被保留。如果您需要原始订单，您可以重新排序（如果原始订单有点特殊，您可以按1,2,3的顺序创建一个新列，然后根据该列重新排序）。这假定您最多只需保留1个S_ZS_（对于每个副本）。如果超过1个 - 毕竟你需要使用VBA（我认为）。 –

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

回答

相关问题