根据重复的单元格和第二列的内容（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列中search重复项。 那么我必须在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
我将不胜感激任何帮助或指导，你可以给我。
我相信这几乎是在那里 – 请确保在运行之前备份您的数据，否则将覆盖数据
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解决scheme：插入新列C假设数据从第1行开始，在C1中input：
=CONCATENATE(A1,MID(B1,5,LEN(B1)-4))
将公式向下复制到C列。然后使用键入列C的删除重复项function