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
189
Office Version
  1. 2016
  2. 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: 20
  • Sheet2.JPG
    Sheet2.JPG
    70.4 KB · Views: 22

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
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:
Upvote 0
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
 
Upvote 0
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: 18
  • C2.JPG
    C2.JPG
    26.8 KB · Views: 19
  • C3.JPG
    C3.JPG
    30.9 KB · Views: 20
Upvote 0
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
 
Upvote 0
Solution
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
 
Upvote 0
Im glad to help you. Thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,213,484
Messages
6,113,924
Members
448,533
Latest member
thietbibeboiwasaco

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
Back
Top