Remove duplicate but move a value to another cell firsts.

[livetolearn4life]

Hello everyone

so what im trying to do , is if Cell A:A has duplicate value then take value in J and L and move them up on the same row as the first instance in column A then remove the duplicates rows.

im am close with this code it's just that but i can't figure the last part of out.

Sub SPIN()

   Dim Ary As Variant, Nary As Variant
   Dim r As Long, nr As Long, c As Long

  Sheets("RAW DATA").Select
   Ary = Sheets("RAW DATA").Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary), 1 To 12)

   For r = 2 To UBound(Ary)
      If Ary(r, 1) <> Ary(r - 1, 1) Then
         nr = nr + 1
         For c = 1 To 12
            Nary(nr, c) = Ary(r, c)
         Next c
      Else
         Nary(nr, 12) = Nary(nr, 12) & ", " & Ary(r, 12)
      End If
   Next r
   Sheets("WHAT I NEED").Select
   Sheets("WHAT I NEED").Range("A2").Resize(nr, 12).Value = Nary
  
End Sub

RECSEQ NUM NAME CODE DATE ISS LOCATION PLAN ORDER CLIENT SHOP OPER# DATE OPERATION COMPLETE 1609776661658 884525blab067 gHRiplby-bNyERgEALiplBTI aa 1/4/2021 glused 8 260 ​ GMT 5 1/6/2021 INS 1/19/2021 GRT 1/20/2021 1609776661658 884525blab067 gHRiplby-bNyERgEALiplBTI aa 1/4/2021 glused 8 311 INS 10 1/19/2021 1609776661658 884525blab067 gHRiplby-bNyERgEALiplBTI aa 1/4/2021 glused 8 220 GRT 15 1/20/2021 THEN DELETE DUPLICATE ROWS 1609776705738 884525blab068 gHRiplby-bNyERgEALiplBTI aa 1/4/2021 glused 8 260 GMT 5 1/6/2021 1609776705738 884525blab068 gHRiplby-bNyERgEALiplBTI aa 1/4/2021 glused 8 311 INS 10 1/19/2021 1609776705738 884525blab068 gHRiplby-bNyERgEALiplBTI aa 1/4/2021 glused 8 220 GRT 15 1/20/2021 1609784640026 885948blab017 PALiplBNEL-IALiplBTCTRg1 aa 1/4/2021 glused 7 RG 260 GMT 5 1/4/2021 1609784640026 885948blab017 PALiplBNEL-IALiplBTCTRg1 aa 1/4/2021 glused 7 RG 311 INS 10 1/27/2021 1609784640026 885948blab017 PALiplBNEL-IALiplBTCTRg1 aa 1/4/2021 glused 7 RG 220 GRT 15 1/27/2021 1609788177705 41611050blab11 TbBE REALiplBR aa 1/4/2021 glused 7 NG 260 GMT 5 1/21/2021 1609788177705 41611050blab11 TbBE REALiplBR aa 1/4/2021 glused 7 NG 311 INS 10 1/28/2021 1609788177705 41611050blab11 TbBE REALiplBR aa 1/4/2021 glused 7 NG 220 GRT 15 1/28/2021 1609862318542 41451064blab3 ALiplBRM HiplbgING iplbTER aa 1/5/2021 glused 1 NG 220 GMT 5 1/5/2021 1609862318542 41451064blab3 ALiplBRM HiplbgING iplbTER aa 1/5/2021 glused 1 NG 221 GMT 10 1/12/2021 1609862318542 41451064blab3 ALiplBRM HiplbgING iplbTER aa 1/5/2021 glused 1 NG 220 GRT 15 1/12/2021 1609882057160 885422blab411 LEG ALiplBggY-ALiplBIgLE aa 1/5/2021 glused 1 NG 221 GMT 5 1/14/2021 1609882057160 885422blab411 LEG ALiplBggY-ALiplBIgLE aa 1/5/2021 glused 1 NG 311 INS 10 9/15/2021 1609882057160 885422blab411 LEG ALiplBggY-ALiplBIgLE aa 1/5/2021 glused 1 NG 221 GRT 15 9/15/2021 1609882095985 885422blab411 LEG ALiplBggY-ALiplBIgLE aa 1/5/2021 glused 1 NG 221 GMT 5 1/20/2021 1609882095985 885422blab411 LEG ALiplBggY-ALiplBIgLE aa 1/5/2021 glused 1 NG 311 INS 10 9/15/2021

 

[Peter_SSs]

When posting vba code, please use the available code tags. My signature block below has more details. I fixed it for you this time.

I'm wondering how big your data is? It may be that an array approach is used, but you could see if this non-array approach does what you want sufficiently well.

Sub Test()
  Dim r As Long, tr As Long
  
  Application.ScreenUpdating = False
  Sheets("RAW DATA").Copy After:=Sheets("RAW DATA")
  With ActiveSheet
    For r = 2 To .Range("A" & Rows.Count).End(xlUp).Row
      If .Range("A" & r).Value <> .Range("A" & r - 1).Value Then
        tr = r
      Else
        .Cells(tr, Columns.Count).End(xlToLeft).Offset(, 1).Resize(, 2).Value = Array(.Cells(r, 10).Value, .Cells(r, 12).Value)
      End If
    Next r
    .UsedRange.RemoveDuplicates Columns:=1
  End With
  Application.ScreenUpdating = True
End Sub

 

[livetolearn4life]

When posting vba code, please use the available code tags. My signature block below has more details. I fixed it for you this time.

I'm wondering how big your data is? It may be that an array approach is used, but you could see if this non-array approach does what you want sufficiently well.

Sub Test()
  Dim r As Long, tr As Long
 
  Application.ScreenUpdating = False
  Sheets("RAW DATA").Copy After:=Sheets("RAW DATA")
  With ActiveSheet
    For r = 2 To .Range("A" & Rows.Count).End(xlUp).Row
      If .Range("A" & r).Value <> .Range("A" & r - 1).Value Then
        tr = r
      Else
        .Cells(tr, Columns.Count).End(xlToLeft).Offset(, 1).Resize(, 2).Value = Array(.Cells(r, 10).Value, .Cells(r, 12).Value)
      End If
    Next r
    .UsedRange.RemoveDuplicates Columns:=1
  End With
  Application.ScreenUpdating = True
End Sub

Hi Peter,
thank you for the response and for the insight on the code tags.

i tried non-array approach you provided and the code was still running after 15 minutes so i finally killed excel through the task manager. i think the array approach would be the best for this case.

in regards to my data size, it is currently at 50,000 rows and 12 columns but could easily grow to double and triple that size depending on the filter i apply coming from the data base.



the code extends keeps going out additional columns to the point that it runs out of columns as shown next.

and this next image is what im trying to accomplish.

 

[Peter_SSs]

Give this one a try. I have assumed sheet 'WHAT I NEED' exists but can have any contents/formatting removed.

Sub Test_v2()
  Dim a As Variant, b As Variant
  Dim r As Long, c As Long, nr As Long, nc As Long, uba2 As Long, maxcols As Long
  
  a = Sheets("RAW DATA").ListObjects(1).Range.Value
  uba2 = UBound(a, 2)
  maxcols = uba2
  ReDim b(1 To UBound(a), 1 To uba2)
  For r = 2 To UBound(a)
    If a(r, 1) = a(r - 1, 1) Then
      If nc > maxcols Then
        ReDim Preserve b(1 To UBound(b), 1 To nc + 1)
        maxcols = nc + 1
      End If
      b(nr, nc) = a(r, 10)
      b(nr, nc + 1) = a(r, 12)
      nc = nc + 2
    Else
      nr = nr + 1
      For c = 1 To uba2
        b(nr, c) = a(r, c)
      Next c
      nc = uba2 + 1
    End If
  Next r
  With Sheets("WHAT I NEED")
    .UsedRange.Clear
    With .Range("A2").Resize(nr, maxcols)
      .Value = b
      .Rows(0).Resize(, uba2).Value = a
      .Parent.ListObjects.Add xlSrcRange, .CurrentRegion, , xlYes
      .EntireColumn.AutoFit
    End With
  End With
End Sub

 

[livetolearn4life]

Give this one a try. I have assumed sheet 'WHAT I NEED' exists but can have any contents/formatting removed.

Sub Test_v2()
  Dim a As Variant, b As Variant
  Dim r As Long, c As Long, nr As Long, nc As Long, uba2 As Long, maxcols As Long
 
  a = Sheets("RAW DATA").ListObjects(1).Range.Value
  uba2 = UBound(a, 2)
  maxcols = uba2
  ReDim b(1 To UBound(a), 1 To uba2)
  For r = 2 To UBound(a)
    If a(r, 1) = a(r - 1, 1) Then
      If nc > maxcols Then
        ReDim Preserve b(1 To UBound(b), 1 To nc + 1)
        maxcols = nc + 1
      End If
      b(nr, nc) = a(r, 10)
      b(nr, nc + 1) = a(r, 12)
      nc = nc + 2
    Else
      nr = nr + 1
      For c = 1 To uba2
        b(nr, c) = a(r, c)
      Next c
      nc = uba2 + 1
    End If
  Next r
  With Sheets("WHAT I NEED")
    .UsedRange.Clear
    With .Range("A2").Resize(nr, maxcols)
      .Value = b
      .Rows(0).Resize(, uba2).Value = a
      .Parent.ListObjects.Add xlSrcRange, .CurrentRegion, , xlYes
      .EntireColumn.AutoFit
    End With
  End With
End Sub

You Nailed it Peter! I appreciate your assistance with this very much sir! Hope you have a blessed and great day!

 

[Peter_SSs]

You're welcome. Thanks for the follow-up.