VBA to copy duplicate data from sheet1 to sheet2 and remove duplicates and leave only unique in sheet2 and get number of count duplicates in sheet2

Prasad K

Board Regular
Joined
Aug 4, 2021
Messages
110
Office Version
  1. 2019
  2. 2016
  3. 2013
  4. 2010
  5. 2007
Platform
  1. Windows
Hi

I am Prasad K

I have a data in sheet1 with duplicates like this below
---------------------------------------------------------------------------------------------------------------------------------------
Column A | Serial No Column B | Date and Year Column C | Inward No Column D | Subject Column E | Section Name
1 29/7/2021 101 ABC CDF
2 29/7/2021 102 DEF CDF
3 29/7/2021 103 GHI CDF
4 27/6/2021 104 CBA FDC
5 27/6/2021 105 FED FDC
6 27/6/2021 106 IHG FDC
-----------------------------------------------------------------------------------------------------------------------------------------
I want copy data from sheet1 to sheet2 with VBA Code like this below
-----------------------------------------------------------------------------------------------------------------------------------------
Column A | Serial No Column B | Date and Year Column C | Section Name Column D | Duplicates Count
1 29/7/2021 CDF 3
2 27/6/2021 FDC 3
-----------------------------------------------------------------------------------------------------------------------------------------
i want to copy duplicate data from specific columns in sheet1 to sheet2 with VBA Code like this i want copy only Column A | Column B | Column E to Column A | Column B | Column C in sheet2 and remove duplicates and leave only unique value in sheet2 and i want to get number of duplicates count in Column D in Sheet2 if Column C | Section Name data match with Column B | Date and Year

Kindly Please anyone help on this
 

Attachments

  • Sheet1.JPG
    Sheet1.JPG
    90.6 KB · Views: 5
  • Sheet2.JPG
    Sheet2.JPG
    70.4 KB · Views: 4

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,771
Office Version
  1. 2007
Platform
  1. Windows
Welcome to the MrExcel Message Board!

Try this:

VBA Code:
Sub remove_duplicates_leave_unique()
  Dim a As Variant, b As Variant
  Dim dic As Object
  Dim i As Long, j As Long
  
  Set dic = CreateObject("Scripting.Dictionary")
  a = Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("E" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a, 1), 1 To 4)
  
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 5)) Then
      j = dic.Count + 1
      dic(a(i, 5)) = j
      b(j, 1) = j
      b(j, 2) = a(i, 2)
      b(j, 3) = a(i, 5)
    Else
      j = dic(a(i, 5))
    End If
    b(j, 4) = b(j, 4) + 1
  Next
  Sheets("Sheet2").Range("A2").Resize(dic.Count, 4).Value = b
End Sub
 
Last edited:

Prasad K

Board Regular
Joined
Aug 4, 2021
Messages
110
Office Version
  1. 2019
  2. 2016
  3. 2013
  4. 2010
  5. 2007
Platform
  1. Windows
Welcome to the MrExcel Message Board!

Try this:

VBA Code:
Sub remove_duplicates_leave_unique()
  Dim a As Variant, b As Variant
  Dim dic As Object
  Dim i As Long, j As Long
 
  Set dic = CreateObject("Scripting.Dictionary")
  a = Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("E" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a, 1), 1 To 4)
 
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 5)) Then
      j = dic.Count + 1
      dic(a(i, 5)) = j
      b(j, 1) = j
      b(j, 2) = a(i, 2)
      b(j, 3) = a(i, 5)
    Else
      j = dic(a(i, 5))
    End If
    b(j, 4) = b(j, 4) + 1
  Next
  Sheets("Sheet2").Range("A2").Resize(dic.Count, 4).Value = b
End Sub
Thank You So Much it's working
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,771
Office Version
  1. 2007
Platform
  1. Windows
I'm glad to help you. Thanks for the feedback.
 

Prasad K

Board Regular
Joined
Aug 4, 2021
Messages
110
Office Version
  1. 2019
  2. 2016
  3. 2013
  4. 2010
  5. 2007
Platform
  1. Windows

ADVERTISEMENT

Welcome to the MrExcel Message Board!

Try this:

VBA Code:
Sub remove_duplicates_leave_unique()
  Dim a As Variant, b As Variant
  Dim dic As Object
  Dim i As Long, j As Long
 
  Set dic = CreateObject("Scripting.Dictionary")
  a = Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("E" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a, 1), 1 To 4)
 
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 5)) Then
      j = dic.Count + 1
      dic(a(i, 5)) = j
      b(j, 1) = j
      b(j, 2) = a(i, 2)
      b(j, 3) = a(i, 5)
    Else
      j = dic(a(i, 5))
    End If
    b(j, 4) = b(j, 4) + 1
  Next
  Sheets("Sheet2").Range("A2").Resize(dic.Count, 4).Value = b
End Sub
Hi Sir
i want one more small help from you

This code is working perfectly to me & i have getting problem in my sheet2 i have attaching screen shot of Sheet1 and Sheet2 and one more Sheet2

when i am copying data from sheet1 to sheet2 the count is adding to same date only like
------------------------------------------------------------------------------------------------------------------
Column B | Date and Year Column C | Section Name
29/7/2021 CDF
29/7/2021 CDF
29/7/2021 CDF
25/2/2021 CDF
25/2/2021 CDF
-----------------------------------------------------------------------------------------------------------------------
coping data from sheet1 to sheet2 i have getting count in Column D like this below
------------------------------------------------------------------------------------------------------------------------
Column B | Date and Year Column C | Section Name Column D | Count
29/7/2021 CDF 5
-----------------------------------------------------------------------------------------------------------------------
i want to copy data sheet1 to sheet2 like this below
-----------------------------------------------------------------------------------------------------------------------
Column B | Date and Year Column C | Section Name Column D | Count
29/7/2021 CDF 3
25/2/2021 CDF 2
------------------------------------------------------------------------------------------------------------------------
Kindly Please Solve my problem
 

Attachments

  • C1.JPG
    C1.JPG
    69.1 KB · Views: 7
  • C2.JPG
    C2.JPG
    26.8 KB · Views: 7
  • C3.JPG
    C3.JPG
    30.9 KB · Views: 7

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,771
Office Version
  1. 2007
Platform
  1. Windows
i want to copy data sheet1 to sheet2 like this below
-----------------------------------------------------------------------------------------------------------------------
Column B | Date and Year Column C | Section Name Column D | Count
29/7/2021 CDF 3
25/2/2021 CDF 2
Try this:

VBA Code:
Sub remove_duplicates_leave_unique()
  Dim a As Variant, b As Variant
  Dim dic As Object
  Dim i As Long, j As Long
  
  Set dic = CreateObject("Scripting.Dictionary")
  a = Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("E" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a, 1), 1 To 4)
  
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 2) & "|" & a(i, 5)) Then
      j = dic.Count + 1
      dic(a(i, 2) & "|" & a(i, 5)) = j
      b(j, 1) = j
      b(j, 2) = a(i, 2)
      b(j, 3) = a(i, 5)
    Else
      j = dic(a(i, 2) & "|" & a(i, 5))
    End If
    b(j, 4) = b(j, 4) + 1
  Next
  Sheets("Sheet2").Range("A2").Resize(dic.Count, 4).Value = b
End Sub
 
Solution

Prasad K

Board Regular
Joined
Aug 4, 2021
Messages
110
Office Version
  1. 2019
  2. 2016
  3. 2013
  4. 2010
  5. 2007
Platform
  1. Windows
Try this:

VBA Code:
Sub remove_duplicates_leave_unique()
  Dim a As Variant, b As Variant
  Dim dic As Object
  Dim i As Long, j As Long
 
  Set dic = CreateObject("Scripting.Dictionary")
  a = Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("E" & Rows.Count).End(3)).Value
  ReDim b(1 To UBound(a, 1), 1 To 4)
 
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 2) & "|" & a(i, 5)) Then
      j = dic.Count + 1
      dic(a(i, 2) & "|" & a(i, 5)) = j
      b(j, 1) = j
      b(j, 2) = a(i, 2)
      b(j, 3) = a(i, 5)
    Else
      j = dic(a(i, 2) & "|" & a(i, 5))
    End If
    b(j, 4) = b(j, 4) + 1
  Next
  Sheets("Sheet2").Range("A2").Resize(dic.Count, 4).Value = b
End Sub
Thank you
it's working
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,771
Office Version
  1. 2007
Platform
  1. Windows
Im glad to help you. Thanks for the feedback.
 

Forum statistics

Threads
1,144,342
Messages
5,723,813
Members
422,518
Latest member
quack_quack

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top