CODEWITHSUNDEEP
vbaexcel
TurboCoder
TurboCoder

Reputation: 1011

VBA - Remove Duplicates Across Multiple Sheets in Workbook

I have multiple sheets in a particular workbook, and n each sheet there are Employee Numbers. The sheets have already been sorted in a way that Column A is always the Employee Number.

So what I need to do is loop through all the sheets and apply the RemoveDuplicates function to delete all duplicate Employee Numbers found in Column A.

Note - I am not trying to have the Employee Number appear on only one sheet; I am trying to have the Employee Number appear only once on each sheet.

I have it working for when I name a specific sheet, but cannot get it to work in a loop.

Test1:

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

Test2:

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

Upvotes: 0

Views: 2930

Answers (1)

paul bica
paul bica

Reputation: 10715

The issue in both tests

  • Set wkbk1 = Workbooks("3rd Party.xlsm") - it implies the code is not in ThisWorkbook, yet
    • Test 1 uses ThisWorkbook - explicitly (For Each ws In ThisWorkbook.Worksheets)
    • Test 2 uses ThisWorkbook - implicitly (With Worksheets(w))
  • For this to work the file "3rd Party.xlsm" must be open at the same time

Try the versions bellow, and if the code is not running in ThisWorkbook, update wb accordingly

(ThisWorkbook is the file where the VBA code is executed from)

.

Version 1 - determine last row and last column

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

If nothing happens when you run either of these versions, the file "3rd Party.xlsm" doesn't exist.
Either it's not open currently, or the name is different - maybe "3rd Party.xlsx" (with an x)

.

If you still have errors for Version 2, .UsedRange may not be what you expect

Try cleaning extra rows and columns with this 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

Upvotes: 2

Related Questions