VBA code to move data in columns by ID in a different column

Hi all,

I have an Excel workbook with ID number in Column A. The same ID can repeat. There are other data in Column C, D and E. I am looking for a VBA code to move data in Column C, D E to the top row of each ID.

like the photo attached.

Excel.jpg

appreciate any help and suggestion. Thank you so much.

Try:

Sub MoveData()
    Application.ScreenUpdating = False
    Dim v As Variant, i As Long, dic As Object, x As Long: x = 2
    v = Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 4).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(v) To UBound(v)
        If Not dic.exists(v(i, 1)) Then
            If v(i, 3) <> "" Or v(i, 4) <> "" Then
                dic.Add v(i, 1), i + 2
            Else
                dic.Add v(i, 1), i + 1
            End If
        Else
            If v(i, 3) <> "" Or v(i, 4) <> "" Then
                Range("C" & dic(v(i, 1))).Resize(, 2) = Array(v(i, 3), v(i, 4))
                Range("C" & i + 1).Resize(, 2).ClearContents
                dic(v(i, 1)) = dic(v(i, 1)) + 1
            End If
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

Originally Posted by Mumps1

Try:

Sub MoveData()
    Application.ScreenUpdating = False
    Dim v As Variant, i As Long, dic As Object, x As Long: x = 2
    v = Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 4).Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(v) To UBound(v)
        If Not dic.exists(v(i, 1)) Then
            If v(i, 3) <> "" Or v(i, 4) <> "" Then
                dic.Add v(i, 1), i + 2
            Else
                dic.Add v(i, 1), i + 1
            End If
        Else
            If v(i, 3) <> "" Or v(i, 4) <> "" Then
                Range("C" & dic(v(i, 1))).Resize(, 2) = Array(v(i, 3), v(i, 4))
                Range("C" & i + 1).Resize(, 2).ClearContents
                dic(v(i, 1)) = dic(v(i, 1)) + 1
            End If
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

This code worked well for my spreadsheet.


There are additional scenarios in my use case.

1. Additional columns to move (ie. Column E, F, G....)
2. If there are no data in column C, D but E

Thank you so much for your help!

Sub Test()
   Sub Test()
  Dim a, i As Long, ii As Long, n As Long, rw&, z As New Collection, b
  a = [a1].CurrentRegion
  Set v = CreateObject("System.collections.sortedlist")
  For i = 2 To UBound(a)
    On Error Resume Next
      z.Add Key:=CStr(a(i, 1)), Item:=CreateObject("System.collections.sortedlist")
       With z(CStr(a(i, 1)))
        .Item(IIf(a(i, 3) = "" And a(i, 4) = "", 100000, i)) = i
       End With
     On Error GoTo 0
  Next i
  n = 1
  ReDim b(1 To UBound(a), 1 To 4)
  b(1, 3) = a(1, 3): b(1, 4) = a(1, 4)
  For i = 2 To UBound(a, 1)
    b(i, 1) = a(i, 1)
    b(i, 2) = a(i, 2)
  Next i
  For i = 1 To z.Count
     For ii = 0 To z(i).Count - 1
         n = n + 1
         rw = z(i).getbyindex(ii)
         b(n, 3) = a(rw, 3): b(n, 4) = a(rw, 4)
     Next ii
     n = n + 1
  Next i
   [h1].Resize(UBound(a, 1), 4).Value = b
End Sub

try this only sort

 

  Option Explicit
  Sub Test()
  Dim a, i As Long, ii As Long, n As Long, rw&, z As New Collection, b
  a = [a1].CurrentRegion
  For i = 2 To UBound(a)
    On Error Resume Next
      z.Add Key:=CStr(a(i, 1)), Item:=CreateObject("System.collections.sortedlist")
       With z(CStr(a(i, 1)))
        .Item(IIf(a(i, 3) = "" And a(i, 4) = "", UBound(a, 1) + 1000, i)) = i
       End With
     On Error GoTo 0
  Next i
  n = 1
  ReDim b(1 To UBound(a), 1 To 4)
  b(1, 1) = a(1, 1): b(1, 2) = a(1, 2)
  b(1, 3) = a(1, 3): b(1, 4) = a(1, 4)
  For i = 2 To UBound(a, 1)
    b(i, 1) = a(i, 1)
    b(i, 2) = a(i, 2)
  Next i
  For i = 1 To z.Count
     For ii = 0 To z(i).Count - 1
         n = n + 1
         rw = z(i).getbyindex(ii)
         b(n, 3) = a(rw, 3): b(n, 4) = a(rw, 4)
     Next ii
     n = n + 1
  Next i
   [h1].Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

maybe you using option explicit,try again i has update code and workbook in post #7

Sub test()
    Dim a, b, x, i As Long
    Application.ScreenUpdating = False
    With [a1].CurrentRegion
        With .Resize(.Rows.Count + 1).Columns(1)
            x = Filter(Evaluate("transpose(if(" & .Address & "<>" & _
            .Offset(1).Address & ",row(" & .Offset(1).Address & ")))"), False, 0)
        End With
        With .Columns("c").Resize(, .Columns.Count - 2)
            For i = 0 To UBound(x) - 1
                If x(i + 1) - x(i) > 1 Then
                    With .Rows(x(i)).Resize(x(i + 1) - x(i))
                        b = Filter(Evaluate("transpose(if(countblank(offset(" & .Address & _
                        ",row(1:" & .Rows.Count & ")-1,,1," & .Columns.Count & "))<" & _
                        .Columns.Count & ",row(1:" & .Rows.Count & ")))"), False, 0)
                        If UBound(b) > -1 Then
                            a = Application.Index(.Value, Application.Transpose(b), _
                                Application.Sequence(1, .Columns.Count, 1))
                            .ClearContents
                            .Resize(UBound(b) + 1) = a
                        End If
                    End With
                End If
            Next
        End With
    End With
    Application.ScreenUpdating = True
End Sub

for dinamic moving area, only change starCol from star col number to moving change 3 to your number col

  
Option Explicit
Const starCol As Long = 3 '>change this to number start moving column
Sub Test()
Dim a, i As Long, ii As Long, r As Range, n As Long, iii As Long, rw&, z As New Collection, b
  Set r = [a1].CurrentRegion
  a = r.Value
  For i = 1 To UBound(a)
    On Error Resume Next
       z.Add Key:=CStr(a(i, 1)), Item:=CreateObject("System.collections.sortedlist")
       With z(CStr(a(i, 1)))
           n = IIf(WorksheetFunction.CountA(r.Offset(, starCol - 1).Resize(, UBound(a, 2) - starCol + 1).Rows(i)) > 0, i, UBound(a, 1) + i)
          .Item(n) = i
        End With
     On Error GoTo 0
  Next i
   ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
   n = 0
   For i = 1 To z.Count
      For ii = 0 To z(i).Count - 1
         n = n + 1: rw = z(i).getbyindex(ii)
         For iii = 1 To starCol - 1
             b(n, iii) = a(n, iii)
         Next iii
         For iii = starCol To UBound(a, 2)
             b(n, iii) = a(rw, iii)
         Next iii
      Next ii
   Next i
   [H1].Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub