Moving duplicate Column Data to individual rows in VBA

[JTGGEORGE]

HI All,

Am trying to Consolidate Multiple line Connote items DIMS.
for example: have column A as Connote number which is listing parcel type Pallet/Carton shipped per Connote number and DIMS associated with each Parel.

ConnoteNumber	Parcel Type	Length	Width	Height	Weight
1234	Pallet	160​	110​	145​	740.00​
1234	Pallet	240​	110​	134​	740.00​
5456	Pallet	120​	120​	120​	360.00​
5456	Pallet	120​	120​	80​	360.00​
5666	Pallet	115​	102​	112​	300.00​
5666	Pallet	77​	117​	108​	300.00​
8888	Carton	21​	120​	120​	85.35​
8888	Carton	21​	120​	120​	85.35​
8888	Carton	21​	120​	120​	85.35​
8888	Carton	25​	42​	29​	85.35​
8888	Carton	18​	66​	15​	85.35​
8888	Carton	11​	95​	17​	85.35​

output: am after is one row per consignment

ConnoteNumber

Parcel Type

Length

Width

Height

Weight

Length2

Width2

Height2

Weight2

Length3

Width3

Height3

Weight3

Length4

Width4

Height4

Weight4

Length4

Width4

Height4

Weight4

1234

Pallet

160​

110​

145​

740.00​

240​

110​

134​

740.00​

5456

Pallet

120​

120​

120​

360.00​

120​

120​

80​

360.00​

5666

Pallet

115​

102​

112​

300.00​

77​

117​

108​

300.00​

8888

Carton

21​

120​

120​

85.35​

21​

120​

120​

85.35​

21​

120​

120​

85.35​

25​

42​

29​

85.35​

11​

95​

17​

85.35​

have 5000+ records each month with 1000 unique Connote numbers associated.
how can i achieve this using VBA/Formula's

thanks,

 

[Peter_SSs]

Welcome to the MrExcel board!

Assuming the original data is in Sheet1 and Sheet2 exists with no data, give this a try with a copy of the workbook.

Sub Combine_Rows()
  Dim d As Object
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, r As Long, c As Long, x As Long, cmax As Long
  Dim s As String
  
  Set d = CreateObject("Scripting.Dictionary")
  With Sheets("Sheet1")
    a = .Range("A2", .Range("F" & Rows.Count).End(xlUp)).Value
  End With
  ReDim b(0 To UBound(a), 1 To 4 * UBound(a) + 2)
  b(0, 1) = "ConnoteNumber": b(0, 2) = "Parcel Type"
  For i = 1 To UBound(a)
    s = a(i, 1) & "|" & a(i, 2)
    If Not d.exists(s) Then
      r = d.Count + 1
      d(s) = Array(r, 3)
      b(r, 1) = a(i, 1): b(r, 2) = a(i, 2)
    End If
    r = d(s)(0)
    c = d(s)(1)
    For j = 0 To 3
      b(r, c + j) = a(i, 3 + j)
    Next j
    d(s) = Array(d(s)(0), d(s)(1) + 4)
    If d(s)(1) > cmax Then
      cmax = d(s)(1) - 1
      x = Int(cmax / 4)
      b(0, cmax - 3) = "Length" & x: b(0, cmax - 2) = "Width" & x: b(0, cmax - 1) = "Height" & x: b(0, cmax) = "Weight" & x
    End If
  Next i
  With Sheets("Sheet2")
    .Range("A1").Resize(d.Count + 1, cmax).Value = b
    .UsedRange.Columns.AutoFit
  End With
End Sub

 

[Legacy 143009]

I hope this will be fast enough. I built the scenario like you have a table in A1:F13. Then I clear the contents of A1:F13 and paste the new values starting form A1 cell again. You can modify it how ever you like.

Sub test()
  Dim myArray As Variant, i As Long, c As Long, j As Long, t As Long
  myArray = Range("A1:F13") 'Your range table
 
  For i = 1 To UBound(myArray, 1) - 1
    If myArray(i + 1, 1) = myArray(i, 1) Then
      c = c + 4
      If UBound(myArray, 2) < c Then
        ReDim Preserve myArray(1 To UBound(myArray, 1), 1 To c)
      End If
      For j = c - 3 To c
        myArray(t, j) = myArray(i + 1, ((j - 3) Mod 4) + 3)
        myArray(i + 1, 1) = ""
      Next
    Else
      c = 6
      t = i + 1
    End If
  Next
 
  For i = 7 To UBound(myArray, 2) Step 4
    For j = 0 To 3
      myArray(1, i + j) = myArray(1, j + 3) & ((i - 3) / 4) + 1
    Next
  Next

  With Application
  .ScreenUpdating = False
  Range("A1:F13").ClearContents'Your range table
  c = 0
  For i = 1 To UBound(myArray, 1)
    If myArray(i, 1) <> "" Then
      'Select where your new table will start
      Range("A1").Offset(c).Resize(1, UBound(myArray, 2)).Value = .Index(myArray, i, 0)
      c = c + 1
    End If
  Next
  .ScreenUpdating = True
  End With
 
End Sub

 

[JTGGEORGE]

Welcome to the MrExcel board!

Assuming the original data is in Sheet1 and Sheet2 exists with no data, give this a try with a copy of the workbook.

Sub Combine_Rows()
  Dim d As Object
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, r As Long, c As Long, x As Long, cmax As Long
  Dim s As String
 
  Set d = CreateObject("Scripting.Dictionary")
  With Sheets("Sheet1")
    a = .Range("A2", .Range("F" & Rows.Count).End(xlUp)).Value
  End With
  ReDim b(0 To UBound(a), 1 To 4 * UBound(a) + 2)
  b(0, 1) = "ConnoteNumber": b(0, 2) = "Parcel Type"
  For i = 1 To UBound(a)
    s = a(i, 1) & "|" & a(i, 2)
    If Not d.exists(s) Then
      r = d.Count + 1
      d(s) = Array(r, 3)
      b(r, 1) = a(i, 1): b(r, 2) = a(i, 2)
    End If
    r = d(s)(0)
    c = d(s)(1)
    For j = 0 To 3
      b(r, c + j) = a(i, 3 + j)
    Next j
    d(s) = Array(d(s)(0), d(s)(1) + 4)
    If d(s)(1) > cmax Then
      cmax = d(s)(1) - 1
      x = Int(cmax / 4)
      b(0, cmax - 3) = "Length" & x: b(0, cmax - 2) = "Width" & x: b(0, cmax - 1) = "Height" & x: b(0, cmax) = "Weight" & x
    End If
  Next i
  With Sheets("Sheet2")
    .Range("A1").Resize(d.Count + 1, cmax).Value = b
    .UsedRange.Columns.AutoFit
  End With
End Sub

thanks, it works perfectly

 

[Peter_SSs]

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