Check Duplicate in Column A and copy column BCD rows and paste using VBA

billigee

New Member
Joined
Sep 18, 2020
Messages
5
Office Version
  1. 2016
  2. 2013
Platform
  1. Windows
  2. Mobile
  3. Web
Hi All,
I need a macro with loop which check duplicate value from column one and copy data from its next four columns and paste in blank columns
For eg
In Column A Row 1 there are item codes and column B,C,D,E have details of conversion
And in Column A row 2 have same code with other conversion details in Columns B,C,D,E
Same as in Column A Row 3

I want Macro to copy conversion (BCDE) details from each duplicate code in column A and paste in next blank column (FGHI)
So thats how I will have unique codes in column A and its conversion details in column B,C,D,E and F,G,H,I and so on
currently its like this
1600495842645.png


after macro running it should like this

1600495881358.png


Any help will be much appreciated.

Thankyou
 

Attachments

  • 1600495778661.png
    1600495778661.png
    101.2 KB · Views: 5

Some videos you may like

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows
Hi and welcome to MrExcel

Try this:

VBA Code:
Sub Check_Duplicate()
  Dim a As Variant, b As Variant, dic As Object
  Dim i As Long, j As Long, k As Long, m As Long
  
  a = Range("A2:E" & Range("A" & Rows.Count).End(3).Row).Value2
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 1) * 4)
  Set dic = CreateObject("Scripting.Dictionary")
  
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 1)) Then
      dic(a(i, 1)) = Array(i, 0)
    Else
      k = dic(a(i, 1))(0)
      m = dic(a(i, 1))(1)
      For j = 2 To 5
        b(k, j - 1 + m) = a(i, j)
        a(i, j) = ""
      Next
      dic(a(i, 1)) = Array(k, m + 4)
    End If
  Next
  
  Range("A2").Resize(UBound(a, 1), 5).Value = a
  Range("F2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
 
Last edited:

billigee

New Member
Joined
Sep 18, 2020
Messages
5
Office Version
  1. 2016
  2. 2013
Platform
  1. Windows
  2. Mobile
  3. Web
Hi and welcome to MrExcel

Try this:

VBA Code:
Sub Check_Duplicate()
  Dim a As Variant, b As Variant, dic As Object
  Dim i As Long, j As Long, k As Long, m As Long
 
  a = Range("A2:E" & Range("A" & Rows.Count).End(3).Row).Value2
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 1) * 4)
  Set dic = CreateObject("Scripting.Dictionary")
 
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 1)) Then
      dic(a(i, 1)) = Array(i, 0)
    Else
      k = dic(a(i, 1))(0)
      m = dic(a(i, 1))(1)
      For j = 2 To 5
        b(k, j - 1 + m) = a(i, j)
        a(i, j) = ""
      Next
      dic(a(i, 1)) = Array(k, m + 4)
    End If
  Next
 
  Range("A2").Resize(UBound(a, 1), 5).Value = a
  Range("F2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
Wow it worked, Thank you so much you saved my whole day as the data is more than 70000 lines, one question if Column A have duplicates more than 4 or 5 rows will it still work?
 

billigee

New Member
Joined
Sep 18, 2020
Messages
5
Office Version
  1. 2016
  2. 2013
Platform
  1. Windows
  2. Mobile
  3. Web

ADVERTISEMENT

Of course the limit will be the number of excel columns.

Check to have the latest version of post #2
Thankyou once again, I am running on small data 300 lines it worked great but when I took 9000 lines it gives me runtime error.
 

billigee

New Member
Joined
Sep 18, 2020
Messages
5
Office Version
  1. 2016
  2. 2013
Platform
  1. Windows
  2. Mobile
  3. Web
on 3000 lines its ok but after 5k to 6k it give runtime error 1004 but if i take 9000 lines it says out of memory
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows

ADVERTISEMENT

Try this:

VBA Code:
Sub Check_Duplicate()
  Dim a As Variant, b As Variant, dic As Object
  Dim i As Long, j As Long, k As Long, m As Long, nMax As Long
  
  a = Range("A2:E" & Range("A" & Rows.Count).End(3).Row).Value2
  Set dic = CreateObject("Scripting.Dictionary")
  
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 1)) Then
      dic(a(i, 1)) = 1
    Else
      dic(a(i, 1)) = dic(a(i, 1)) + 1
      If dic(a(i, 1)) > nMax Then nMax = dic(a(i, 1))
    End If
  Next
  ReDim b(1 To UBound(a, 1), 1 To nMax * 4)
  dic.RemoveAll
  
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 1)) Then
      dic(a(i, 1)) = Array(i, 0)
    Else
      k = dic(a(i, 1))(0)
      m = dic(a(i, 1))(1)
      For j = 2 To 5
        b(k, j - 1 + m) = a(i, j)
        a(i, j) = ""
      Next
      dic(a(i, 1)) = Array(k, m + 4)
    End If
  Next
  
  Range("A2").Resize(UBound(a, 1), 5).Value = a
  Range("F2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
 

billigee

New Member
Joined
Sep 18, 2020
Messages
5
Office Version
  1. 2016
  2. 2013
Platform
  1. Windows
  2. Mobile
  3. Web
Try this:

VBA Code:
Sub Check_Duplicate()
  Dim a As Variant, b As Variant, dic As Object
  Dim i As Long, j As Long, k As Long, m As Long, nMax As Long
 
  a = Range("A2:E" & Range("A" & Rows.Count).End(3).Row).Value2
  Set dic = CreateObject("Scripting.Dictionary")
 
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 1)) Then
      dic(a(i, 1)) = 1
    Else
      dic(a(i, 1)) = dic(a(i, 1)) + 1
      If dic(a(i, 1)) > nMax Then nMax = dic(a(i, 1))
    End If
  Next
  ReDim b(1 To UBound(a, 1), 1 To nMax * 4)
  dic.RemoveAll
 
  For i = 1 To UBound(a)
    If Not dic.exists(a(i, 1)) Then
      dic(a(i, 1)) = Array(i, 0)
    Else
      k = dic(a(i, 1))(0)
      m = dic(a(i, 1))(1)
      For j = 2 To 5
        b(k, j - 1 + m) = a(i, j)
        a(i, j) = ""
      Next
      dic(a(i, 1)) = Array(k, m + 4)
    End If
  Next
 
  Range("A2").Resize(UBound(a, 1), 5).Value = a
  Range("F2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

sorry for late reply, its awesome now, working perfectly
Thankyou so much
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows
Again with pleasure. Thanks for the feedback
 

Watch MrExcel Video

Forum statistics

Threads
1,122,509
Messages
5,596,558
Members
414,077
Latest member
ammylar5

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