Vba to delete entire row of duplicate and original data entries

[GID1]

Hi

Can anyone help me out . I am having a hard time on this one. I would like to delete of entire row of the duplicate and original in column E whenever i enter duplicate in the Column E. Please kindly see the attached image. In the image i have two tables top is before and bottom table is after deleting the entire row of the duplicate and original in column E.


Thank you.

GD

 

[Alex Blakenburg]

The below code below assumes your Table starts in A1, that the sheet you want to use is the active sheet, and that you are only looking at Column E to determine if something is a duplicate or not.

An XL2BB of the test data:

20221016 VBA Remove Duplicates GID1.xlsm
	A	B	C	D	E	F	G
1	Location	Part Number	Description	Code	Serial Number	Date	Remarks
2	1A	B1B	Book	123	1A2	12/10/2022	Taken
3	1A	B2B	Pencil	124	1A3	13/10/2022	Taken
4	1A	B1B	Eraser	125	1A1	14/10/2022	Taken
5	1A	B4B	Ruler	126	1A4	15/10/2022	Taken
6	1A	B1B	Book	123	1A2	12/10/2022	Taken
Data

Sub RemoveDuplicates()

    Dim shtData As Worksheet, shtRpt As Worksheet
    Dim rngData As Range, arrData As Variant
    Dim lrowData As Long, lcolData As Long, nxtColData As Long
    Dim rngRptInclHdg As Range, rngRpt As Range, arrRpt As Variant
    Dim dictData As Object, dictKey As String
    Dim i As Long, NoOfRows As Long

    Set shtData = ActiveSheet
 
    With shtData
        lrowData = .Cells(Rows.Count, "E").End(xlUp).Row
        lcolData = .Cells(1, Columns.Count).End(xlToLeft).Column
        nxtColData = lcolData + 1
        Set rngData = .Range(.Cells(1, "A"), .Cells(lrowData, nxtColData))
        arrData = rngData.Value
    End With
 
    Set dictData = CreateObject("Scripting.dictionary")
 
    ' Load details into Dictionary and flag duplicates
    For i = 1 To UBound(arrData)
        dictKey = arrData(i, 5)
        If Not dictData.exists(dictKey) Then
            dictData(dictKey) = i
        Else
            arrData(i, nxtColData) = 1
            arrData(dictData(dictKey), nxtColData) = 1        ' Could test for already set to 1 but no real added value
        End If
    Next i
 
    rngData.Columns(lcolData + 1) = Application.Index(arrData, 0, lcolData + 1)
 
    ' Delete duplicate rows
    NoOfRows = Application.Count(rngData.Columns(nxtColData))
    If NoOfRows > 0 Then
        Application.ScreenUpdating = False
        With rngData.Resize(, nxtColData)
          .Sort Key1:=.Columns(nxtColData), Order1:=xlAscending, Header:=xlNo
          .Resize(NoOfRows).EntireRow.Delete
        End With
        Application.ScreenUpdating = True
  End If
 
End Sub

 

[GID1]

The below code below assumes your Table starts in A1, that the sheet you want to use is the active sheet, and that you are only looking at Column E to determine if something is a duplicate or not.

An XL2BB of the test data:

20221016 VBA Remove Duplicates GID1.xlsm
	A	B	C	D	E	F	G
1	Location	Part Number	Description	Code	Serial Number	Date	Remarks
2	1A	B1B	Book	123	1A2	12/10/2022	Taken
3	1A	B2B	Pencil	124	1A3	13/10/2022	Taken
4	1A	B1B	Eraser	125	1A1	14/10/2022	Taken
5	1A	B4B	Ruler	126	1A4	15/10/2022	Taken
6	1A	B1B	Book	123	1A2	12/10/2022	Taken
Data

Sub RemoveDuplicates()

    Dim shtData As Worksheet, shtRpt As Worksheet
    Dim rngData As Range, arrData As Variant
    Dim lrowData As Long, lcolData As Long, nxtColData As Long
    Dim rngRptInclHdg As Range, rngRpt As Range, arrRpt As Variant
    Dim dictData As Object, dictKey As String
    Dim i As Long, NoOfRows As Long

    Set shtData = ActiveSheet
 
    With shtData
        lrowData = .Cells(Rows.Count, "E").End(xlUp).Row
        lcolData = .Cells(1, Columns.Count).End(xlToLeft).Column
        nxtColData = lcolData + 1
        Set rngData = .Range(.Cells(1, "A"), .Cells(lrowData, nxtColData))
        arrData = rngData.Value
    End With
 
    Set dictData = CreateObject("Scripting.dictionary")
 
    ' Load details into Dictionary and flag duplicates
    For i = 1 To UBound(arrData)
        dictKey = arrData(i, 5)
        If Not dictData.exists(dictKey) Then
            dictData(dictKey) = i
        Else
            arrData(i, nxtColData) = 1
            arrData(dictData(dictKey), nxtColData) = 1        ' Could test for already set to 1 but no real added value
        End If
    Next i
 
    rngData.Columns(lcolData + 1) = Application.Index(arrData, 0, lcolData + 1)
 
    ' Delete duplicate rows
    NoOfRows = Application.Count(rngData.Columns(nxtColData))
    If NoOfRows > 0 Then
[/QUOTE]








[QUOTE="Alex Blakenburg, post: 5962486, member: 473943"]
        Application.ScreenUpdating = False
        With rngData.Resize(, nxtColData)
          .Sort Key1:=.Columns(nxtColData), Order1:=xlAscending, Header:=xlNo
          .Resize(NoOfRows).EntireRow.Delete
        End With
        Application.ScreenUpdating = True
  End If
 
End Sub

Hi Alex,

Thank you so much for ur reply. It does delete the entire rows of duplicates and its original in Column E, but there is one issue. In Row One , the text from the head drop down and fill in the below cells.
Please take a look at the image. Could u please advise me what could be done.
Thank you so much for ur help.

 

[Alex Blakenburg]

I am afraid I don't understand what you are trying to say.

Was row 2 there in the data original data ?
Show me before, after and what you are expecting.

 

[GID1]

Hi

Here is the attachment.


The result becomes like this after the macro run, to record the date i use this code :
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Cells(Target.Row, "M") = Date
Application.EnableEvents = True

End Sub

But the main concern is show below.Please take a look.

Location	Part Number	Descr	Code	Serial Number	Date	Remarks
				1A1		Taken
Location	Part Number	Descr	Code	1A5	Date	Taken

 

[Alex Blakenburg]

You did not answer my questions or provide the visibility over your data before, after & expected that I asked for.

There is nothing in the code that will generate your line 3. It looks to me that your source data has the heading repeating in the data. I don't know how it is picking up altered data in the Serial Number and Remarks field.

In nearly all cases macros need to know the Column & Row numbers in which the data resides. All your images and sample do not show Column & Row references.

If you provide the necessary information I can trouble shoot the issue.

 

[GID1]

This is before i enter duplicate.

Error (version 1).xlsb
	A	B	C	D	E	F	G
1	Location	Part Number	Descr	Code	Serial Number	Date	Remarks
2	1A	B1B	Pencil	124	1A3	44850	Taken
3	1A	B2B	Eraser	125	1A1	44850	Taken
4	1A	B3B	Ruler	126	1A4	44850	Taken
5	1A	B4B	Book	126	1A5	44850	Taken
Sheet2

This is after i enter the duplicate serial number "1A3" the table should look like this.

Location	Part Number	Descr	Code	Serial Number	Date	Remarks
1A	B2B	Eraser	125	1A1	10/16/2022	Taken
1A	B3B	Ruler	126	1A4	10/16/2022	Taken
1A	B4B	Book	126	1A5	10/16/2022	Taken

[/XD][/XR][/RANGE]

 

[GID1]

This is the main sheet that i would like to run the macro.

Error.xlsm
	A	B	C	D	E	F	G
1	Location	Part Number	Descr	Code	Serial Number	Date	Remarks
2	1A	B1B	Pencil	124	1A3	13/10/2022	Taken
3	1A	B2B	Eraser	125	1A1	14/10/2022	Taken
4	1A	B3B	Ruler	126	1A4	15/10/2022	Taken
5	1A	B4B	Book	126	1A5	15/10/2023	Taken
6
Stock In-Out

Cell Formulas
Range	Formula
A2:A6	A2	=IFERROR(INDEX(Inventory!A:A,MATCH('Stock In-Out'!E2,Inventory!E:E,0)),"")
B2:B6	B2	=IFERROR(INDEX(Inventory!B:B,MATCH('Stock In-Out'!E2,Inventory!E:E,0)),"")
C2:C6	C2	=IFERROR(INDEX(Inventory!C:C,MATCH('Stock In-Out'!E2,Inventory!E:E,0)),"")
D2:D6	D2	=IFERROR(INDEX(Inventory!D:D,MATCH('Stock In-Out'!E2,Inventory!E:E,0)),"")
F2:F6	F2	=IFERROR(INDEX(Inventory!G:G,MATCH('Stock In-Out'!E2,Inventory!E:E,0)),"")

This is the second sheet that is tracking the inventory in and out. So whenever the serial number is entered in the main sheet

 

[GID1]

This is the main sheet that i would like to run the macro.

Error.xlsm
	A	B	C	D	E	F	G
1	Location	Part Number	Descr	Code	Serial Number	Date	Remarks
2	1A	B1B	Pencil	124	1A3	13/10/2022	Taken
3	1A	B2B	Eraser	125	1A1	14/10/2022	Taken
4	1A	B3B	Ruler	126	1A4	15/10/2022	Taken
5	1A	B4B	Book	126	1A5	15/10/2023	Taken
6
Stock In-Out

Cell Formulas
Range	Formula
A2:A6	A2	=IFERROR(INDEX(Inventory!A:A,MATCH('Stock In-Out'!E2,Inventory!E:E,0)),"")
B2:B6	B2	=IFERROR(INDEX(Inventory!B:B,MATCH('Stock In-Out'!E2,Inventory!E:E,0)),"")
C2:C6	C2	=IFERROR(INDEX(Inventory!C:C,MATCH('Stock In-Out'!E2,Inventory!E:E,0)),"")
D2:D6	D2	=IFERROR(INDEX(Inventory!D:D,MATCH('Stock In-Out'!E2,Inventory!E:E,0)),"")
F2:F6	F2	=IFERROR(INDEX(Inventory!G:G,MATCH('Stock In-Out'!E2,Inventory!E:E,0)),"")

This is the second sheet that is tracking the inventory in and out. So whenever the serial number is entered in the main sheet

This is the main sheet"Stock In>Out" which i would like to run the macro.

Error.xlsm
	A	B	C	D	E	F	G
1	Location	Part Number	Descr	Code	Serial Number	Date	Remarks
2	1A	B1B	Pencil	124	1A3	13/10/2022	Taken
3	1A	B2B	Eraser	125	1A1	14/10/2022	Taken
4	1A	B3B	Ruler	126	1A4	15/10/2022	Taken
5	1A	B4B	Book	126	1A5	15/10/2023	Taken
6
Stock In-Out

Cell Formulas
Range	Formula
A2:A6	A2	=IFERROR(INDEX(Inventory!A:A,MATCH('Stock In-Out'!E2,Inventory!E:E,0)),"")
B2:B6	B2	=IFERROR(INDEX(Inventory!B:B,MATCH('Stock In-Out'!E2,Inventory!E:E,0)),"")
C2:C6	C2	=IFERROR(INDEX(Inventory!C:C,MATCH('Stock In-Out'!E2,Inventory!E:E,0)),"")
D2:D6	D2	=IFERROR(INDEX(Inventory!D:D,MATCH('Stock In-Out'!E2,Inventory!E:E,0)),"")
F2:F6	F2	=IFERROR(INDEX(Inventory!G:G,MATCH('Stock In-Out'!E2,Inventory!E:E,0)),"")

This is the second sheet that is tracking the inventory in and out. So whenever the serial number is entered in the main sheet"Stock In>Out" , the status column in this sheet will change to "Taken".
as i have enter the formula to do so. So when the duplicates serial number is entered again into the main sheet"Stock In>Out" , i need that duplicates and the original to be deleted off from cell, so that the status column in this sheet will change back to "In Inventory".

Here is the second sheet.

Error (version 2).xlsb
	A	B	C	D	E	F	G	H
1	Location	Part Number	Descr	Code	Serial Number	Status	Date	Remarks
2	1A	B1B	Pencil	124	1A3	In Inventory	13/10/2022	Taken
3	1A	B2B	Eraser	125	1A1	In Inventory	14/10/2022	Taken
4	1A	B3B	Ruler	126	1A4	In Inventory	15/10/2022	Taken
5	1A	B4B	Book	126	1A5	In Inventory	15/10/2023	Taken
6
7
8
9
10
11
Inventory

Cell Formulas
Range	Formula
H2:H11	H2	=IFERROR(INDEX('Stock In-Out'!G:G,MATCH(Inventory!E2,'Stock In-Out'!E:E,0)),"")

Pardon me for my english. Thank you for being patience and helping me out on this one.

 

[Alex Blakenburg]

The information in the last post was perfect.

It is generally not good practice to reference the sheet name of the current sheet in the formula.
Having said that I would not have expected that it would be impacted by a sort but that appears to be the case.

Go to your sheet > Stock In-Out
Press Ctrl+H (replace)
In the find what box copy the following > 'Stock In-Out'!
Leave the replace with Box empty
Replace All
Save the spreadsheet.

Then rerun the macro and tell me what happens.