根據重複的單元格和第二列的內容刪除行（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）

回答

相關問題