VBA - 删除工作簿中多个工作表的重复项

Question

我在一个特定的工作簿中有多个工作表，每个工作表都有员工编号。工作表已经按照 A 列始终是员工编号的方式进行了排序。

所以我需要做的是遍历所有工作表并应用 RemoveDuplicates 函数删除在 A 列中找到的所有重复的员工编号。

注意 - 我不想让员工编号只出现在一张纸上；我试图让员工编号在每张纸上只出现一次。

当我命名一个特定的工作表时，它可以工作，但不能让它循环工作。

测试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 - 使用范围

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