VBA-刪除工作簿中多個工作表之間的重復項

Question

我在一個特定的工作簿中有多個工作表，每張工作表中都有n個員工編號。 工作表已經按照A列始終為員工編號的方式進行了排序。

因此，我需要做的是遍歷所有工作表並應用RemoveDuplicates函數刪除在A列中找到的所有重復的員工編號。

注意-我不是想讓Employee Number只出現在一張紙上； 我試圖讓員工編號在每張紙上只出現一次。

當我命名特定工作表時，它可以工作，但是無法使其循環工作。

測試1：

Sub deleteDuplicate()

    Dim ws As Worksheet
    Dim wkbk1 As Workbook
    Dim w As Long
    Dim lRow As Long
    Dim iCntr As Long

    Set wkbk1 = Workbooks("3rd Party.xlsm")

    wkbk1.Activate

    For Each ws In ThisWorkbook.Worksheets

        ' Find last row in column A
        lRow = ws.Range("A" & ws.Rows.count).End(xlUp).Row

        For iCntr = lRow To 1 Step -1

            ws.lRow.RemoveDuplicates Columns:=1, Header:=xlYes

        Next iCntr

    Next ws

End Sub

測試2：

Sub deleteDuplicate()

    Dim ws As Worksheet
    Dim wkbk1 As Workbook
    Dim w As Long
    Dim lRow As Long
    Dim iCntr As Long

    Set wkbk1 = Workbooks("3rd Party.xlsm")

    wkbk1.Activate

    With wkbk1

        For w = 1 To .Worksheets.count

            With Worksheets(w)

                .UsedRange.RemoveDuplicates Columns:=1, Header:=xlYes

            End With

        Next w

    End With

End Sub

Answer 1

兩個測試中的問題

• Set wkbk1 = Workbooks("3rd Party.xlsm") -這意味着代碼不在ThisWorkbook ，
  • Test 1使用ThisWorkbook顯式（ For Each ws In ThisWorkbook.Worksheets ）
  • Test 2隱式使用ThisWorkbook （ With Worksheets(w) ）
• 為此，必須同時打開"3rd Party.xlsm"文件

請嘗試以下版本，如果代碼未在ThisWorkbook運行，請相應地更新wb

（ ThisWorkbook是執行VBA代碼的文件）

---

。

Version 1確定最后一行和最后一列

Option Explicit

Public Sub DeleteDuplicates1()
    Dim wb As Workbook, ws As Worksheet, lr As Long, lc As Long, ur As Range

    On Error Resume Next    'Expected error: wb not found
    Set wb = ThisWorkbook   'Workbooks("3rd Party.xlsm")

    If Not wb Is Nothing Then
        Application.ScreenUpdating = False
        For Each ws In wb.Worksheets
            lr = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
            Set ur = ws.Range("A1", ws.Cells(lr, lc))
            ur.RemoveDuplicates Columns:=Array(1), Header:=xlYes
        Next
        Application.ScreenUpdating = True
    End If
End Sub

---

。

Version 2 -UsedRange

Public Sub DeleteDuplicates2()
    Dim wb As Workbook, ws As Worksheet

    On Error Resume Next    'Expected error: wb not found
    Set wb = ThisWorkbook   'Workbooks("3rd Party.xlsm")

    If Not wb Is Nothing Then
        Application.ScreenUpdating = False
        For Each ws In wb.Worksheets
            ws.UsedRange.RemoveDuplicates Columns:=Array(1), Header:=xlYes
        Next
        Application.ScreenUpdating = True
    End If
End Sub

---

如果在運行這些版本中的任何一個時都沒有任何反應，則文件"3rd Party.xlsm"不存在。
它當前未打開，或者名稱不同-可能是"3rd Party.xlsx" （帶有x ）

。

如果您仍然有版本2的錯誤， .UsedRange可能不是您所期望的

嘗試使用此Sub清潔多余的行和列

---

Public Sub RemoveEmptyRowsAndColumns()
    Dim wb As Workbook, ws As Worksheet, lr As Long, lc As Long, er As Range, ec As Range

    On Error Resume Next    'Expected error: wb not found
    Set wb = ThisWorkbook   'Workbooks("3rd Party.xlsm")

    If Not wb Is Nothing Then
        Application.ScreenUpdating = False
        For Each ws In wb.Worksheets

            lr = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

            If lr > 1 And lc > 1 Then

                Set er = ws.Range(ws.Cells(lr + 1, "A"), ws.Cells(ws.Rows.Count, "A"))
                Set ec = ws.Range(ws.Cells(1, lc + 1), ws.Cells(1, ws.Columns.Count))

                er.EntireRow.Delete     'Shift:=xlUp
                ec.EntireColumn.Delete  'Shift:=xlToLeft
            End If
        Next
        Application.ScreenUpdating = True
    End If
End Sub