Hi,

I have the following data that needs to be on the same row

Part Number Aml Part
ABC123456 XY123456
ABC123456 XY324567
ABC123456 JKT67893
GBC123456 HFYRUTR
FBC123456 JGHTYRE
FBC123456 LK456789
FBC123456 LGJTUR45
CCHF7899 LIE475869540403

Result would be

Part Number Aml Part
ABC123456 XY123456, XY324567, JKT67893
GBC123456 HFYRUTR
FBC123456 JGHTYRE, LK456789, LGJTUR45
CCHF7899 LIE475869540403

There will be 1000's of records, a Part Number can have any number of
Aml Parts

I do have code I wrote that works but it is very slow

Any help greatly appreciated

Rgds
Raymond Allan

Theres bound to be some funky array/unary formula to do this - but I dont do
funky formulas. I would do it some like this (only very lightly tested).
Could easily be made into a sub rather than UDF.

Option Explicit

Public Function ParseItems(rngDataIn As Range)

Dim outArr() As Variant ' OK this could be str
Dim varItr As Variant
Dim i As Long

Dim dicParts As Scripting.Dictionary
Dim dicAmlParts As Scripting.Dictionary

Set dicParts = New Scripting.Dictionary

For i = LBound(rngDataIn.Value) To UBound(rngDataIn.Value)

If Not dicParts.Exists(rngDataIn(i, 1).Value) Then
Set dicAmlParts = New Scripting.Dictionary
dicParts.Add rngDataIn(i, 1).Value, dicAmlParts
End If

If Not dicParts(rngDataIn(i, 1).Value).Exists(rngDataIn(i, 2).Value) Then
dicParts(rngDataIn(i, 1).Value).Add rngDataIn(i, 2).Value,
rngDataIn(i, 2).Value
End If

Next i

ReDim outArr(1 To dicParts.Count, 1 To 2)

i = 1
For Each varItr In dicParts
outArr(i, 1) = varItr
outArr(i, 2) = Join(dicParts(varItr).Items, ",")
i = i + 1
Next varItr

ParseItems = outArr

End Function

p.s. You will need to set a reference to "Microsoft scripting runtime" from
the VBE by going to tools - references and ticking it.

" wrote:

Hi,

I have the following data that needs to be on the same row

Part Number Aml Part
ABC123456 XY123456
ABC123456 XY324567
ABC123456 JKT67893
GBC123456 HFYRUTR
FBC123456 JGHTYRE
FBC123456 LK456789
FBC123456 LGJTUR45
CCHF7899 LIE475869540403

Result would be

Part Number Aml Part
ABC123456 XY123456, XY324567, JKT67893
GBC123456 HFYRUTR
FBC123456 JGHTYRE, LK456789, LGJTUR45
CCHF7899 LIE475869540403

There will be 1000's of records, a Part Number can have any number of
Aml Parts

I do have code I wrote that works but it is very slow

Any help greatly appreciated

Rgds
Raymond Allan

I use this. It is a lot of code, but it has been tried and tested and works
fine.
It has gives you some extra options as well. You could leave the sorting out
if you do this in the sheet.

Function SwingArray(ByRef arr1 As Variant, _
ByRef colToTest As Long, _
ByRef DoSort As Boolean, _
ByRef StartCol As Long, _
Optional ByRef lDiscardLastCols As Long = 0) As Variant

'takes one multi-column 2D array and swings the elements
'that have the same value in colToTest to the row where
'this value was found first. Column colToTest will only
'hold unique values in the resulting array.
'StartCol is the column where the copying of the elements
'starts from.
'--------------------------------------------------------
Dim arr2()
Dim i As Long
Dim n As Long
Dim c As Long
Dim c2 As Long
Dim c3 As Long
Dim maxItems As Long
Dim uCo As Long
Dim LBR1 As Long
Dim UBR1 As Long
Dim LBC1 As Long
Dim UBC1 As Long
Dim tempIdx As Long
Dim arrError(0 To 0)

On Error GoTo ERROROUT

LBR1 = LBound(arr1, 1)
UBR1 = UBound(arr1, 1)
LBC1 = LBound(arr1, 2)
UBC1 = UBound(arr1, 2) - lDiscardLastCols

'adjust UBR1 to account for empty elements
'these empty element have to be at the
'bottom of the array if they are there
'-----------------------------------------
For i = LBR1 To UBR1
If arr1(i, colToTest) = Empty Then
UBR1 = i - 1
Exit For
End If
Next

'sorting the supplied array ascending
'------------------------------------
If DoSort = True Then
If PreSort2DArray(arr1, _
"A", _
colToTest) = False Then
On Error GoTo 0
SwingArray = False
Exit Function
End If
End If

'find and mark the doubles
'get the maximum number of doubles
'---------------------------------
tempIdx = arr1(LBR1, colToTest)

For i = LBR1 + 1 To UBR1
If Not arr1(i, colToTest) = tempIdx Then
tempIdx = arr1(i, colToTest)
uCo = uCo + 1
c2 = 0
Else
arr1(i, LBC1) = 0
c2 = c2 + 1
If c2 maxItems Then
maxItems = c2
End If
End If
Next

'adjust the final array
'LBound will be as the original array
'------------------------------------
ReDim arr2(LBR1 To uCo + LBR1, _
LBC1 To (UBC1) + maxItems * (((UBC1 + 1) - StartCol)))

n = LBR1 - 1

'swing the elements from vertical to horizontal
'----------------------------------------------
For i = LBR1 To UBR1
If Not arr1(i, LBC1) = 0 Then
'copy first row in full
n = n + 1
For c = LBC1 To UBC1
arr2(n, c) = arr1(i, c)
Next
c3 = UBC1 + 1
Else
'copy subsequent rows from specified start column
'------------------------------------------------
For c = StartCol To UBC1
arr2(n, c3) = arr1(i, c)
c3 = c3 + 1
Next
End If
Next

SwingArray = arr2

On Error GoTo 0
Exit Function
ERROROUT:

arrError(0) = "ERROR"
SwingArray = arrError

On Error GoTo 0
End Function

Function PreSort2DArray(ByRef avArray, _
ByRef sOrder As String, _
ByRef iKey As Long, _
Optional ByRef iLow1 As Long = -1, _
Optional ByRef iHigh1 As Long = -1) As Boolean

'the routine procSort2D can't handle large arrays
'causing an error out of stack space
'this is handled by sorting increasing larger parts
'of the array, so that there is less to be done when
'the whole array gets sorted
'---------------------------------------------------

Dim LR As Long
Dim lPreSorts As Long
Dim lArrayChunk As Long
Dim n As Long

LR = UBound(avArray)

'this value may depend on the hardware
'-------------------------------------
lArrayChunk = 8000

'no need to do pre-sorts
'-----------------------
If LR < lArrayChunk Then
PreSort2DArray = procSort2D(avArray, _
sOrder, _
iKey, _
iLow1, _
iHigh1)
Exit Function
End If

lPreSorts = LR \ lArrayChunk

For n = 0 To lPreSorts
If n < lPreSorts Then
'increase the part of the array in steps of lArrayChunk
'------------------------------------------------------
PreSort2DArray = procSort2D(avArray, _
sOrder, _
iKey, _
iLow1, _
(n + 1) * lArrayChunk)
Else
'sort the whole array
'--------------------
PreSort2DArray = procSort2D(avArray, _
sOrder, _
iKey, _
iLow1, _
iHigh1)
End If
Next

End Function

Function procSort2D(ByRef avArray, _
ByRef sOrder As String, _
ByRef iKey As Long, _
Optional ByRef iLow1 As Long = -1, _
Optional ByRef iHigh1 As Long = -1) As Boolean

Dim iLow2 As Long
Dim iHigh2 As Long
Dim i As Long
Dim vItem1 As Variant
Dim vItem2 As Variant

On Error GoTo ERROROUT

If iLow1 = -1 Then
iLow1 = LBound(avArray, 1)
End If

If iHigh1 = -1 Then
iHigh1 = UBound(avArray, 1)
End If

'Set new extremes to old extremes
iLow2 = iLow1
iHigh2 = iHigh1

'Get value of array item in middle of new extremes
vItem1 = avArray((iLow1 + iHigh1) \ 2, iKey)

'Loop for all the items in the array between the extremes
While iLow2 < iHigh2

If sOrder = "A" Then
'Find the first item that is greater than the mid-point item
While avArray(iLow2, iKey) < vItem1 And iLow2 < iHigh1
iLow2 = iLow2 + 1
Wend

'Find the last item that is less than the mid-point item
While avArray(iHigh2, iKey) vItem1 And iHigh2 iLow1
iHigh2 = iHigh2 - 1
Wend
Else
'Find the first item that is less than the mid-point item
While avArray(iLow2, iKey) vItem1 And iLow2 < iHigh1
iLow2 = iLow2 + 1
Wend

'Find the last item that is greater than the mid-point item
While avArray(iHigh2, iKey) < vItem1 And iHigh2 iLow1
iHigh2 = iHigh2 - 1
Wend
End If

'If the two items are in the wrong order, swap the rows
If iLow2 < iHigh2 Then
For i = LBound(avArray) To UBound(avArray, 2)
vItem2 = avArray(iLow2, i)
avArray(iLow2, i) = avArray(iHigh2, i)
avArray(iHigh2, i) = vItem2
Next
End If

'If the pointers are not together, advance to the next item
If iLow2 <= iHigh2 Then
iLow2 = iLow2 + 1
iHigh2 = iHigh2 - 1
End If
Wend

'Recurse to sort the lower half of the extremes
If iHigh2 iLow1 Then procSort2D avArray, sOrder, iKey, iLow1, iHigh2

'Recurse to sort the upper half of the extremes
If iLow2 < iHigh1 Then procSort2D avArray, sOrder, iKey, iLow2, iHigh1

procSort2D = True

Exit Function
ERROROUT:

procSort2D = False

End Function


RBS


wrote in message
ups.com...
Hi,

I have the following data that needs to be on the same row

Part Number Aml Part
ABC123456 XY123456
ABC123456 XY324567
ABC123456 JKT67893
GBC123456 HFYRUTR
FBC123456 JGHTYRE
FBC123456 LK456789
FBC123456 LGJTUR45
CCHF7899 LIE475869540403

Result would be

Part Number Aml Part
ABC123456 XY123456, XY324567, JKT67893
GBC123456 HFYRUTR
FBC123456 JGHTYRE, LK456789, LGJTUR45
CCHF7899 LIE475869540403

There will be 1000's of records, a Part Number can have any number of
Aml Parts

I do have code I wrote that works but it is very slow

Any help greatly appreciated

Rgds
Raymond Allan

Hi Ben,

Thanks for taking the time to look at this

Silly question, but how do I call the function ?

Raymond


On 5 Jun, 14:24, Ben McBen wrote:
p.s. You will need to set a reference to "Microsoft scripting runtime" from
the VBE by going to tools - references and ticking it.



" wrote:
Hi,

I have the following data that needs to be on the same row

Part Number Aml Part
ABC123456 XY123456
ABC123456 XY324567
ABC123456 JKT67893
GBC123456 HFYRUTR
FBC123456 JGHTYRE
FBC123456 LK456789
FBC123456 LGJTUR45
CCHF7899 LIE475869540403

Result would be

Part Number Aml Part
ABC123456 XY123456, XY324567, JKT67893
GBC123456 HFYRUTR
FBC123456 JGHTYRE, LK456789, LGJTUR45
CCHF7899 LIE475869540403

There will be 1000's of records, a Part Number can have any number of
Aml Parts

I do have code I wrote that works but it is very slow

Any help greatly appreciated

Rgds
Raymond Allan- Hide quoted text -

- Show quoted text -

It needs to be input as an array formula (CTRL SHIFT ENTER) over a range. It
can simply be made into a sub by:

1.
Public Sub ParseItems(rngDataIn As Range)

....
2.
range("whatever") = outArr
End sub


" wrote:

Hi Ben,

Thanks for taking the time to look at this

Silly question, but how do I call the function ?

Raymond


On 5 Jun, 14:24, Ben McBen wrote:
p.s. You will need to set a reference to "Microsoft scripting runtime" from
the VBE by going to tools - references and ticking it.



" wrote:
Hi,

I have the following data that needs to be on the same row

Part Number Aml Part
ABC123456 XY123456
ABC123456 XY324567
ABC123456 JKT67893
GBC123456 HFYRUTR
FBC123456 JGHTYRE
FBC123456 LK456789
FBC123456 LGJTUR45
CCHF7899 LIE475869540403

Result would be

Part Number Aml Part
ABC123456 XY123456, XY324567, JKT67893
GBC123456 HFYRUTR
FBC123456 JGHTYRE, LK456789, LGJTUR45
CCHF7899 LIE475869540403

There will be 1000's of records, a Part Number can have any number of
Aml Parts

I do have code I wrote that works but it is very slow

Any help greatly appreciated

Rgds
Raymond Allan- Hide quoted text -

- Show quoted text -

Raymond,
Another way...
Data must be in two columns.
Data must be sorted by column 1.
Select the data (exclude the header).
Run the code.
'---
Sub MoveEmOver()
Dim rngAll As Range
Dim rngCell As Range
Dim rngTemp As Range
Dim N As Long
Set rngAll = Selection
N = 1
Application.ScreenUpdating = False
For Each rngCell In rngAll.Columns(1).Cells
If rngTemp Is Nothing Then Set rngTemp = rngCell
If rngCell(2, 1).Value = rngTemp.Value Then
N = N + 1
rngTemp.Offset(0, N).Value = rngCell(2, 2).Value
Range(rngCell(2, 1), rngCell(2, 2)).ClearContents
Else
N = 1
Set rngTemp = Nothing
End If
Next
rngAll.EntireRow.Sort rngAll(1)
Application.ScreenUpdating = True
Set rngCell = Nothing
Set rngTemp = Nothing
Set rngAll = Nothing
End Sub
--
Jim Cone
San Francisco, USA
http://www.realezsites.com/bus/primitivesoftware




wrote in message
Hi,
I have the following data that needs to be on the same row
Part Number Aml Part
ABC123456 XY123456
ABC123456 XY324567
ABC123456 JKT67893
GBC123456 HFYRUTR
FBC123456 JGHTYRE
FBC123456 LK456789
FBC123456 LGJTUR45
CCHF7899 LIE475869540403

Result would be
Part Number Aml Part
ABC123456 XY123456, XY324567, JKT67893
GBC123456 HFYRUTR
FBC123456 JGHTYRE, LK456789, LGJTUR45
CCHF7899 LIE475869540403

There will be 1000's of records, a Part Number can have any number of Aml Parts
I do have code I wrote that works but it is very slow
Any help greatly appreciated
Rgds
Raymond Allan

One thing: If speed is important (and the original post
suggested that) then I would always get the data in an
array, manipulate the array and then write back to the
sheet. It will be a lot faster.

RBS

"Jim Cone" wrote in message
...
Raymond,
Another way...
Data must be in two columns.
Data must be sorted by column 1.
Select the data (exclude the header).
Run the code.
'---
Sub MoveEmOver()
Dim rngAll As Range
Dim rngCell As Range
Dim rngTemp As Range
Dim N As Long
Set rngAll = Selection
N = 1
Application.ScreenUpdating = False
For Each rngCell In rngAll.Columns(1).Cells
If rngTemp Is Nothing Then Set rngTemp = rngCell
If rngCell(2, 1).Value = rngTemp.Value Then
N = N + 1
rngTemp.Offset(0, N).Value = rngCell(2, 2).Value
Range(rngCell(2, 1), rngCell(2, 2)).ClearContents
Else
N = 1
Set rngTemp = Nothing
End If
Next
rngAll.EntireRow.Sort rngAll(1)
Application.ScreenUpdating = True
Set rngCell = Nothing
Set rngTemp = Nothing
Set rngAll = Nothing
End Sub
--
Jim Cone
San Francisco, USA
http://www.realezsites.com/bus/primitivesoftware




wrote in message
Hi,
I have the following data that needs to be on the same row
Part Number Aml Part
ABC123456 XY123456
ABC123456 XY324567
ABC123456 JKT67893
GBC123456 HFYRUTR
FBC123456 JGHTYRE
FBC123456 LK456789
FBC123456 LGJTUR45
CCHF7899 LIE475869540403

Result would be
Part Number Aml Part
ABC123456 XY123456, XY324567, JKT67893
GBC123456 HFYRUTR
FBC123456 JGHTYRE, LK456789, LGJTUR45
CCHF7899 LIE475869540403

There will be 1000's of records, a Part Number can have any number of Aml
Parts
I do have code I wrote that works but it is very slow
Any help greatly appreciated
Rgds
Raymond Allan

RBS,
I agree, with the exception that in some infrequent instances it is not faster.
If speed is a concern, I will compare times on a couple of different methods.
I suspect (and hope Raymond lets us know) that he did not turn off ScreenUpdating.
Regards,
Jim Cone


"RB Smissaert"
wrote in message
One thing: If speed is important (and the original post
suggested that) then I would always get the data in an
array, manipulate the array and then write back to the
sheet. It will be a lot faster.

RBS

"Jim Cone" wrote in message
...
Raymond,
Another way...
Data must be in two columns.
Data must be sorted by column 1.
Select the data (exclude the header).
Run the code.
'---
Sub MoveEmOver()
Dim rngAll As Range
Dim rngCell As Range
Dim rngTemp As Range
Dim N As Long
Set rngAll = Selection
N = 1
Application.ScreenUpdating = False
For Each rngCell In rngAll.Columns(1).Cells
If rngTemp Is Nothing Then Set rngTemp = rngCell
If rngCell(2, 1).Value = rngTemp.Value Then
N = N + 1
rngTemp.Offset(0, N).Value = rngCell(2, 2).Value
Range(rngCell(2, 1), rngCell(2, 2)).ClearContents
Else
N = 1
Set rngTemp = Nothing
End If
Next
rngAll.EntireRow.Sort rngAll(1)
Application.ScreenUpdating = True
Set rngCell = Nothing
Set rngTemp = Nothing
Set rngAll = Nothing
End Sub
--
Jim Cone
San Francisco, USA
http://www.realezsites.com/bus/primitivesoftware




wrote in message
Hi,
I have the following data that needs to be on the same row
Part Number Aml Part
ABC123456 XY123456
ABC123456 XY324567
ABC123456 JKT67893
GBC123456 HFYRUTR
FBC123456 JGHTYRE
FBC123456 LK456789
FBC123456 LGJTUR45
CCHF7899 LIE475869540403

Result would be
Part Number Aml Part
ABC123456 XY123456, XY324567, JKT67893
GBC123456 HFYRUTR
FBC123456 JGHTYRE, LK456789, LGJTUR45
CCHF7899 LIE475869540403

There will be 1000's of records, a Part Number can have any number of Aml
Parts
I do have code I wrote that works but it is very slow
Any help greatly appreciated
Rgds
Raymond Allan

Yes, only testing will tell for sure.
I am at work now, but will see if I can run some tests
later.

RBS

"Jim Cone" wrote in message
...

RBS,
I agree, with the exception that in some infrequent instances it is not
faster.
If speed is a concern, I will compare times on a couple of different
methods.
I suspect (and hope Raymond lets us know) that he did not turn off
ScreenUpdating.
Regards,
Jim Cone


"RB Smissaert"
wrote in message
One thing: If speed is important (and the original post
suggested that) then I would always get the data in an
array, manipulate the array and then write back to the
sheet. It will be a lot faster.

RBS

"Jim Cone" wrote in message
...
Raymond,
Another way...
Data must be in two columns.
Data must be sorted by column 1.
Select the data (exclude the header).
Run the code.
'---
Sub MoveEmOver()
Dim rngAll As Range
Dim rngCell As Range
Dim rngTemp As Range
Dim N As Long
Set rngAll = Selection
N = 1
Application.ScreenUpdating = False
For Each rngCell In rngAll.Columns(1).Cells
If rngTemp Is Nothing Then Set rngTemp = rngCell
If rngCell(2, 1).Value = rngTemp.Value Then
N = N + 1
rngTemp.Offset(0, N).Value = rngCell(2, 2).Value
Range(rngCell(2, 1), rngCell(2, 2)).ClearContents
Else
N = 1
Set rngTemp = Nothing
End If
Next
rngAll.EntireRow.Sort rngAll(1)
Application.ScreenUpdating = True
Set rngCell = Nothing
Set rngTemp = Nothing
Set rngAll = Nothing
End Sub
--
Jim Cone
San Francisco, USA
http://www.realezsites.com/bus/primitivesoftware




wrote in message
Hi,
I have the following data that needs to be on the same row
Part Number Aml Part
ABC123456 XY123456
ABC123456 XY324567
ABC123456 JKT67893
GBC123456 HFYRUTR
FBC123456 JGHTYRE
FBC123456 LK456789
FBC123456 LGJTUR45
CCHF7899 LIE475869540403

Result would be
Part Number Aml Part
ABC123456 XY123456, XY324567, JKT67893
GBC123456 HFYRUTR
FBC123456 JGHTYRE, LK456789, LGJTUR45
CCHF7899 LIE475869540403

There will be 1000's of records, a Part Number can have any number of Aml
Parts
I do have code I wrote that works but it is very slow
Any help greatly appreciated
Rgds
Raymond Allan

Have run a quick test on data like this:

Sub FillRange()

Dim i As Long
Dim arr(1 To 65535, 1 To 2) As Long

Application.ScreenUpdating = False

For i = 1 To 65535
arr(i, 1) = Int((10000 * Rnd) + 1)
arr(i, 2) = Int((100 * Rnd) + 1)
Next i

Range(Cells(1), Cells(65535, 2)) = arr
Range(Cells(1), Cells(65535, 1)).Sort Cells(2, 1), xlAscending
Range(Cells(1), Cells(65535, 2)).Select

Application.ScreenUpdating = True

End Sub


ParseItems: 4 secs
MoveEmOver: 16 secs
SwingArray: 115 millisecs

I think this shows how much faster working on arrays can be compared to
working on ranges.
This is with data that is sorted on column 1.
If data is unsorted then the sort will lengthen MoveEmOver and SwingArray.
ParseItems doesn't rely on the data being sorted on column 1.

I altered ParseItems a bit to make it produce an array and make it take an
array
argument rather than a range as that will make it about a third faster:

Function ParseItems(arrDataIn As Variant) As Long()

Dim outArr() As Long
Dim varItr As Variant
Dim varItr2 As Variant
Dim i As Long
Dim c As Long
Dim n As Long
Dim x As Long
Dim z As Long
Dim lMaxCount As Long

Dim dicParts As Scripting.Dictionary
Dim dicAmlParts As Scripting.Dictionary

Set dicParts = New Scripting.Dictionary

For i = LBound(arrDataIn) To UBound(arrDataIn)

If Not dicParts.Exists(arrDataIn(i, 1)) Then
Set dicAmlParts = New Scripting.Dictionary
dicParts.Add arrDataIn(i, 1), dicAmlParts
z = z + 1
c = 1
Else
c = c + 1
If c lMaxCount Then
lMaxCount = c
End If
End If

'could filter out unique items here
dicParts(arrDataIn(i, 1)).Add i, arrDataIn(i, 2)

Next i

ReDim outArr(1 To z, 1 To lMaxCount + 1) As Long

For Each varItr In dicParts
n = n + 1
outArr(n, 1) = varItr
x = 0
For Each varItr2 In dicParts(varItr).Items
x = x + 1
outArr(n, x + 1) = varItr2
Next varItr2
Next varItr

ParseItems = outArr

End Function


RBS



"Jim Cone" wrote in message
...

RBS,
I agree, with the exception that in some infrequent instances it is not
faster.
If speed is a concern, I will compare times on a couple of different
methods.
I suspect (and hope Raymond lets us know) that he did not turn off
ScreenUpdating.
Regards,
Jim Cone


"RB Smissaert"
wrote in message
One thing: If speed is important (and the original post
suggested that) then I would always get the data in an
array, manipulate the array and then write back to the
sheet. It will be a lot faster.

RBS

"Jim Cone" wrote in message
...
Raymond,
Another way...
Data must be in two columns.
Data must be sorted by column 1.
Select the data (exclude the header).
Run the code.
'---
Sub MoveEmOver()
Dim rngAll As Range
Dim rngCell As Range
Dim rngTemp As Range
Dim N As Long
Set rngAll = Selection
N = 1
Application.ScreenUpdating = False
For Each rngCell In rngAll.Columns(1).Cells
If rngTemp Is Nothing Then Set rngTemp = rngCell
If rngCell(2, 1).Value = rngTemp.Value Then
N = N + 1
rngTemp.Offset(0, N).Value = rngCell(2, 2).Value
Range(rngCell(2, 1), rngCell(2, 2)).ClearContents
Else
N = 1
Set rngTemp = Nothing
End If
Next
rngAll.EntireRow.Sort rngAll(1)
Application.ScreenUpdating = True
Set rngCell = Nothing
Set rngTemp = Nothing
Set rngAll = Nothing
End Sub
--
Jim Cone
San Francisco, USA
http://www.realezsites.com/bus/primitivesoftware




wrote in message
Hi,
I have the following data that needs to be on the same row
Part Number Aml Part
ABC123456 XY123456
ABC123456 XY324567
ABC123456 JKT67893
GBC123456 HFYRUTR
FBC123456 JGHTYRE
FBC123456 LK456789
FBC123456 LGJTUR45
CCHF7899 LIE475869540403

Result would be
Part Number Aml Part
ABC123456 XY123456, XY324567, JKT67893
GBC123456 HFYRUTR
FBC123456 JGHTYRE, LK456789, LGJTUR45
CCHF7899 LIE475869540403

There will be 1000's of records, a Part Number can have any number of Aml
Parts
I do have code I wrote that works but it is very slow
Any help greatly appreciated
Rgds
Raymond Allan

Did run MoveEmOver on the wrong range and it is in fact 30 secs.

RBS


"RB Smissaert" wrote in message
...
Have run a quick test on data like this:

Sub FillRange()

Dim i As Long
Dim arr(1 To 65535, 1 To 2) As Long

Application.ScreenUpdating = False

For i = 1 To 65535
arr(i, 1) = Int((10000 * Rnd) + 1)
arr(i, 2) = Int((100 * Rnd) + 1)
Next i

Range(Cells(1), Cells(65535, 2)) = arr
Range(Cells(1), Cells(65535, 1)).Sort Cells(2, 1), xlAscending
Range(Cells(1), Cells(65535, 2)).Select

Application.ScreenUpdating = True

End Sub


ParseItems: 4 secs
MoveEmOver: 16 secs
SwingArray: 115 millisecs

I think this shows how much faster working on arrays can be compared to
working on ranges.
This is with data that is sorted on column 1.
If data is unsorted then the sort will lengthen MoveEmOver and SwingArray.
ParseItems doesn't rely on the data being sorted on column 1.

I altered ParseItems a bit to make it produce an array and make it take an
array
argument rather than a range as that will make it about a third faster:

Function ParseItems(arrDataIn As Variant) As Long()

Dim outArr() As Long
Dim varItr As Variant
Dim varItr2 As Variant
Dim i As Long
Dim c As Long
Dim n As Long
Dim x As Long
Dim z As Long
Dim lMaxCount As Long

Dim dicParts As Scripting.Dictionary
Dim dicAmlParts As Scripting.Dictionary

Set dicParts = New Scripting.Dictionary

For i = LBound(arrDataIn) To UBound(arrDataIn)

If Not dicParts.Exists(arrDataIn(i, 1)) Then
Set dicAmlParts = New Scripting.Dictionary
dicParts.Add arrDataIn(i, 1), dicAmlParts
z = z + 1
c = 1
Else
c = c + 1
If c lMaxCount Then
lMaxCount = c
End If
End If

'could filter out unique items here
dicParts(arrDataIn(i, 1)).Add i, arrDataIn(i, 2)

Next i

ReDim outArr(1 To z, 1 To lMaxCount + 1) As Long

For Each varItr In dicParts
n = n + 1
outArr(n, 1) = varItr
x = 0
For Each varItr2 In dicParts(varItr).Items
x = x + 1
outArr(n, x + 1) = varItr2
Next varItr2
Next varItr

ParseItems = outArr

End Function


RBS



"Jim Cone" wrote in message
...

RBS,
I agree, with the exception that in some infrequent instances it is not
faster.
If speed is a concern, I will compare times on a couple of different
methods.
I suspect (and hope Raymond lets us know) that he did not turn off
ScreenUpdating.
Regards,
Jim Cone


"RB Smissaert"
wrote in message
One thing: If speed is important (and the original post
suggested that) then I would always get the data in an
array, manipulate the array and then write back to the
sheet. It will be a lot faster.

RBS

"Jim Cone" wrote in message
...
Raymond,
Another way...
Data must be in two columns.
Data must be sorted by column 1.
Select the data (exclude the header).
Run the code.
'---
Sub MoveEmOver()
Dim rngAll As Range
Dim rngCell As Range
Dim rngTemp As Range
Dim N As Long
Set rngAll = Selection
N = 1
Application.ScreenUpdating = False
For Each rngCell In rngAll.Columns(1).Cells
If rngTemp Is Nothing Then Set rngTemp = rngCell
If rngCell(2, 1).Value = rngTemp.Value Then
N = N + 1
rngTemp.Offset(0, N).Value = rngCell(2, 2).Value
Range(rngCell(2, 1), rngCell(2, 2)).ClearContents
Else
N = 1
Set rngTemp = Nothing
End If
Next
rngAll.EntireRow.Sort rngAll(1)
Application.ScreenUpdating = True
Set rngCell = Nothing
Set rngTemp = Nothing
Set rngAll = Nothing
End Sub
--
Jim Cone
San Francisco, USA
http://www.realezsites.com/bus/primitivesoftware




wrote in message
Hi,
I have the following data that needs to be on the same row
Part Number Aml Part
ABC123456 XY123456
ABC123456 XY324567
ABC123456 JKT67893
GBC123456 HFYRUTR
FBC123456 JGHTYRE
FBC123456 LK456789
FBC123456 LGJTUR45
CCHF7899 LIE475869540403

Result would be
Part Number Aml Part
ABC123456 XY123456, XY324567, JKT67893
GBC123456 HFYRUTR
FBC123456 JGHTYRE, LK456789, LGJTUR45
CCHF7899 LIE475869540403

There will be 1000's of records, a Part Number can have any number of
Aml
Parts
I do have code I wrote that works but it is very slow
Any help greatly appreciated
Rgds
Raymond Allan

RBS,
Thanks for running the numbers. I won't argue. <g

However, I did run a couple of tests of 1000 rows with the data
already filled in the two columns,
MoveEmOver took only about 1/4 second.
But if more was data added the time required increased exponentially.
--
Jim Cone
San Francisco, USA
http://www.realezsites.com/bus/primitivesoftware


"RB Smissaert"
wrote in message
Did run MoveEmOver on the wrong range and it is in fact 30 secs.
RBS

Actually the figures weren't completely fair as they didn't include putting
the data from the range into the array and vice-versa.
This adds about 250 millisecs.
Still.

RBS


"Jim Cone" wrote in message
...
RBS,
Thanks for running the numbers. I won't argue. <g

However, I did run a couple of tests of 1000 rows with the data
already filled in the two columns,
MoveEmOver took only about 1/4 second.
But if more was data added the time required increased exponentially.
--
Jim Cone
San Francisco, USA
http://www.realezsites.com/bus/primitivesoftware


"RB Smissaert"
wrote in message
Did run MoveEmOver on the wrong range and it is in fact 30 secs.
RBS