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

我在一个特定工作簿中有多张工作表，每张工作表上都有员工编号。工作表已按a列始终为员工编号的方式进行排序

因此，我需要做的是遍历所有工作表，并应用RemovedUpplicates函数删除A列中所有重复的员工编号

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

当我命名一个特定的工作表时，它可以工作，但无法使它在循环中工作

测试1：

测试2：

---

这两个测试中的问题

• Set wkbk1=Workbooks（“3rd Party.xlsm”）

  -这意味着代码不在本工作簿中

  • 测试1

    明确使用

    此工作簿

    （

    用于此工作簿中的每个ws。工作表

    ）

  • 测试2

    隐式地使用

    此工作簿

    （

    与工作表（w）

    ）
• 要使其工作，必须同时打开文件

  “3rd Party.xlsm”

请尝试下面的版本，如果代码未在此工作簿中运行，请相应地更新

wb

（

此工作簿

是执行VBA代码的文件）

---

版本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

---

第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

可能不是您所期望的

尝试使用此子对象清理额外的行和列

---

---

这两个测试中的问题

• Set wkbk1=Workbooks（“3rd Party.xlsm”）

  -这意味着代码不在本工作簿中

  • 测试1

    明确使用

    此工作簿

    （

    用于此工作簿中的每个ws。工作表

    ）

  • 测试2

    隐式地使用

    此工作簿

    （

    与工作表（w）

    ）
• 要使其工作，必须同时打开文件

  “3rd Party.xlsm”

请尝试下面的版本，如果代码未在此工作簿中运行，请相应地更新

wb

（

此工作簿

是执行VBA代码的文件）

---

版本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

---

第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

可能不是您所期望的

尝试使用此子对象清理额外的行和列

---

---

在测试1中，您没有在循环中使用

iCntr

。但是，测试2对我来说很好。@d讽刺的是，我在测试2-应用程序定义或对象定义的错误中遇到了一个错误。您的工作簿名是什么？在宏中的第三行

Set wkbk1=Workbooks（“3rd Party.xlsm”）

？我试图让您的代码正常工作，但失败了（大）我发现我的excel（2003）版本不支持RemovedUpplicates功能。你正在运行哪个版本的Excel？@dwirony我有那一行代码。调试卡在线路上。UsedRange.RemovedUpplicates列：=1，标题：=xlYes，出现我上面提到的错误。在测试1中，您没有在循环中使用

iCntr

。但是，测试2对我来说很好。@d讽刺的是，我在测试2-应用程序定义或对象定义的错误中遇到了一个错误。您的工作簿名是什么？在宏中的第三行

Set wkbk1=Workbooks（“3rd Party.xlsm”）

？我试图让您的代码正常工作，但失败了（大）我发现我的excel（2003）版本不支持RemovedUpplicates功能。你正在运行哪个版本的Excel？@dwirony我有那一行代码。调试卡在线路上。UsedRange.RemovedUpplicates列：=1，标题：=xlYes，出现我上面提到的错误。非常感谢您的帮助@Paul Bica。它非常有效，我非常感谢您在回复中所做的努力。：）很高兴它有帮助！非常感谢您的帮助@Paul Bica。它非常有效，我非常感谢您在回复中所做的努力。：）很高兴它有帮助！

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