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

[billigee]

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

after macro running it should like this

Any help will be much appreciated.

Thankyou

 

[DanteAmor]

Hi and welcome to MrExcel

Try this:

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

 

[billigee]

Hi and welcome to MrExcel

Try this:

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?

 

[DanteAmor]

more than 4 or 5 rows will it still work?

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

Check to have the latest version of post #2

 

[billigee]

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]

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]

Try this:

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]

Try this:

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]

Again with pleasure. Thanks for the feedback