Excel VBA 刪除范圍內的重復項

Question

我正在努力更新一些包含主數據的工作表。

用戶可以使用新項目更新寄存器（“TK_Register”）或修改（“EditEX”）表上的現有項目。 EditEx 工作表上的數據保存在 C32:P56 並保存在 TK_Register 工作表的下一個空行（A 到 N 列）

使用不同的代碼，我可以根據參考編號（存儲在單元格 O32:O56 的 EditEX 表和列 M 的 TK_Register 表中）調用所有特定的行。

在運行此代碼時，

• excel 從 EditEx 工作表 C32:P56 中獲取所有數據
• 將此數據粘貼到 TK_Register 表上的下一個空行
• 基於列“N”的“NO”自動過濾器（即不需要保留此行）
• 刪除過濾的行（這些是未使用的行並包含默認數據）
• 取消過濾數據

這是我遇到問題的地方。 將所有數據添加到 TK_Register 表包括新項目以及已更新的先前項目。 由於我們需要定期添加、更新和更改，當我們需要再次編輯它時，我們只想看到最新的行項目出現在 EditEx 工作表上。

然后，用戶可以對任何召回的行進行更改和/或添加新行。

我下面的代碼僅適用於最后一行參考號（M 列）重復的情況。 如果添加的行超過 1 行，則找不到重復項。 我知道我要經歷很長的路要走，但是有什么想法可以讓它搜索每個粘貼的參考號（M列）（將有多行），如果找到的話，用新數據更新該行，如果沒有找到，添加到下一個可用行。

    Sub SaveUpdatedRec()

        Dim rng4 As Range
        Set rng4 = Sheets("EditEx").Range("C32:P56")
        Sheets("TK_Register").Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(rng4.Rows.Count, rng4.Columns.Count).Cells.Value = rng4.Cells.Value
        Sheets("TK_Register").Range("A1:N1000").AutoFilter field:=14, Criteria1:="NO"
        Application.DisplayAlerts = False
        Sheets("TK_Register").Range("A2:N1000").SpecialCells(xlCellTypeVisible).Delete
        Application.DisplayAlerts = True
        On Error Resume Next
        Sheets("TK_Register").ShowAllData
        On Error GoTo 0


    Sheets("AI_Register").Select
      Range("A1").Select

       Dim lrow1 As Long
       For lrow1 = Worksheets("AI_Register").Cells(Rows.Count, "M").End(xlUp).Row To 2 Step -1
           If Cells(lrow1, "M") = Cells(lrow1, "M").Offset(-1, 0) Then
              Cells(lrow1, "M").Offset(-1, 0).EntireRow.Delete
           End If

        Next lrow1

       ActiveWorkbook.RefreshAll
        Sheets("EditEx").Select
        ActiveWindow.SmallScroll Down:=-120
        Range("B13").Select

    MsgBox ("Record Updates have been Saved")

    End Sub

Answer 1

下面是一個使用.RemoveDupliates的示例代碼，它從給定范圍的第 1 列中刪除重復項，考慮到該列具有 header。

Option Explicit

Sub test()

    Dim LastroW As Long

    With ThisWorkbook.Worksheets("Sheet1")

        LastroW = .Cells(.Rows.Count, "A").End(xlUp).Row

        .Range("A1:A" & LastroW).RemoveDuplicates Columns:=1, Header:=xlYes

    End With

End Sub