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

P

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: 36
  • Sheet2.JPG
    Sheet2.JPG
    70.4 KB · Views: 38

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.
Sort by date Sort by votes
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
DanteAmor said:
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
Click to expand...
Thank You So Much it's working
 
Upvote 0
DanteAmor said:
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
Click to expand...
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: 32
  • C2.JPG
    C2.JPG
    26.8 KB · Views: 31
  • C3.JPG
    C3.JPG
    30.9 KB · Views: 30
Upvote 0
Prasad K said:
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
Click to expand...
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
DanteAmor said:
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
Click to expand...
Thank you
it's working
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
Extract the require data from Sheet1 to Sheet2 (Total Consumption For an Item for a period in Sheet1 For Several Items) in another sheet2 get in deta
2
Replies
10
Views
224
DanteAmor
DanteAmor
T
  • Solved
How can I filter duplicates from a worksheet column out of a data validation list drop-down box?
Replies
5
Views
236
Peter_SSs
Peter_SSs
willow1985
  • Solved
VBA Select all rows from active cell (selected cell) on table to 2nd last row
Replies
3
Views
262
rlv01
R
youbitto
  • Solved
Copy paste from multiple Excel and Csv files to another excel file VBA
Replies
2
Views
207
youbitto
youbitto
M
  • Solved
Chose random % of row from sheet1 and paste in to sheet2
Replies
3
Views
247
motilulla
M

Forum statistics

Threads
1,224,755
Messages
6,180,751
Members
452,996
Latest member
nelsonsix66

Share this page

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