PDA

View Full Version : Solved: sorting columns with duplicates



Croeg
11-17-2006, 07:42 PM
Hello all,

I'm trying to find a macro or function that will recognize duplicates in column A, and combine column Bs results next to column A (with each result in next column). For example, here's what my columns look like:

200604200214 ECO Folder is complete
200604200214 690206366
200604200214 TID missing
200607270050 690206412
200607270050 TID missing
200608160137 690200160
200608160137 ECO Folder is complete
200608170103 ECO Folder is complete
200608170103 690206341
200608170103 TID missing
200608210052 690103335
200608210052 ECO Folder is complete

Here's what I wish the result was:
200604200214 690206366 TID missing ECO Folder is complete
200607270050 690206412 TID missing ECO Folder is complete
200608160137 690200160 ECO Folder is complete
200608170103 690206341 TID missing ECO Folder is complete
200608210052 690103335 ECO Folder is complete

Thanks for any assistance !


Croeg

jindon
11-17-2006, 08:14 PM
Hi
try

Sub test()
Dim dic As Object, a, i As Long, y, w()
Set dic = CreateObject("Scripting.Dictionary")
a = Range("a1").CurrentRegion.Resize(,2).Value
For i = 1 To UBound(a,1)
If Not dic.exists(a(i,1)) Then
dic.add a(i,1), Array(a(i,1), a(i,2))
Else
w = dic(a(i,1)) : ReDim Preserve w(UBound(w) + 1)
If w(UBound(w)) = "ECO Folder complete" Then
w(UBound(w)) = w(UBound(w) - 1) : w(UBound(w) - 1) = a(i,2)
Else
w(UBound(w)) = a(i,2)
End If
dic(a(i,1)) = w
End If
Next
y = dic.items : Set dic = Nothing : Erase a
With Range("d1")
.CurrentRegion.ClearContents
For i = 0 To UBound(y)
.Offset(i).Resize(,UBound(y(i)) + 1).Value = y(i)
Next
End With
End Sub

Croeg
11-17-2006, 08:31 PM
Hi Jindon,

THANKS SO MUCH! I can see that it is working however I'm encountering a runtime error. Possibly I am missing a reference? It seems to be hung up on the last part of the macro:

.Offset(i).Resize(, UBound(y(i)) + 1).Value = y(i)


Which brings me to another question, would you know if any changes will need to be made if this is run using Excel 2000? Multiple users with different versions will be using this program.

Thanks again! :rotlaugh:

Croeg

jindon
11-17-2006, 08:52 PM
Hummmm

Can you run the code and read the msgbox for me?

Sub test()
Dim dic As Object, a, i As Long, y, w()
Set dic = CreateObject("Scripting.Dictionary")
a = Range("a1").CurrentRegion.Resize(,2).Value
For i = 1 To UBound(a,1)
If Not dic.exists(a(i,1)) Then
dic.add a(i,1), Array(a(i,1), a(i,2))
Else
w = dic(a(i,1)) : ReDim Preserve w(UBound(w) + 1)
If w(UBound(w)) = "ECO Folder complete" Then
w(UBound(w)) = w(UBound(w) - 1) : w(UBound(w) - 1) = a(i,2)
Else
w(UBound(w)) = a(i,2)
End If
dic(a(i,1)) = w
End If
Next
y = dic.items : Set dic = Nothing : Erase a
With Range("d1")
.CurrentRegion.ClearContents
For i = 0 To UBound(y)
MsgBox UBound(y(i))
.Offset(i).Resize(,UBound(y(i)) + 1).Value = y(i)
Next
End With
End Sub

Croeg
11-17-2006, 08:59 PM
Jindon,

Here's the reported error:

Run-time error '1004':
Application-defined or object-defined error

I've tried adding Microsoft Scripting Runtime with no luck...still the same error.

Thanks

Croeg

jindon
11-17-2006, 09:05 PM
Can you run the code and read the msgbox for me?

Sub test()
Dim dic As Object, a, i As Long, y, w()
Set dic = CreateObject("Scripting.Dictionary")
a = Range("a1").CurrentRegion.Resize(,2).Value
For i = 1 To UBound(a,1)
If Not dic.exists(a(i,1)) Then
dic.add a(i,1), Array(a(i,1), a(i,2))
Else
w = dic(a(i,1)) : ReDim Preserve w(UBound(w) + 1)
If w(UBound(w)) = "ECO Folder complete" Then
w(UBound(w)) = w(UBound(w) - 1) : w(UBound(w) - 1) = a(i,2)
Else
w(UBound(w)) = a(i,2)
End If
dic(a(i,1)) = w
End If
Next
y = dic.items : Set dic = Nothing : Erase a
With Range("d1")
.CurrentRegion.ClearContents
For i = 0 To UBound(y)
MsgBox UBound(y(i))
.Offset(i).Resize(,UBound(y(i)) + 1).Value = y(i)
Next
End With
End Sub

Croeg
11-17-2006, 09:06 PM
I wonder if the error alarms at the end because nothing is returned at end. If I enter an on error statement, it works. But I'm not sure if that is the correct thing to do.

Here's what I added:

Sub test()
Dim dic As Object, a, i As Long, w(), temp
Set dic = CreateObject("Scripting.Dictionary")
a = Range("a1").CurrentRegion.Resize(, 2).Value
For i = 1 To UBound(a, 1)
If Not dic.exists(a(i, 1)) Then
dic.Add a(i, 1), Array(a(i, 1), a(i, 2))
Else
w = dic(a(i, 1)): ReDim Preserve w(UBound(w) + 1)
If w(UBound(w)) = "ECO Folder complete" Then
w(UBound(w)) = w(UBound(w) - 1): w(UBound(w) - 1) = a(i, 2)
Else
w(UBound(w)) = a(i, 2)
End If
dic(a(i, 1)) = w
End If
Next
On Error GoTo finish

y = dic.items: Set dic = Nothing: Erase a
With Range("d1")
.CurrentRegion.ClearContents
For i = 0 To UBound(y)
.Offset(i).Resize(, UBound(y(i)) + 1).Value = y(i)
Next
End With
finish:
Exit Sub
End Sub


Croeg

jindon
11-17-2006, 09:06 PM
Can you try this again and see if you can read the message

Sub test()
Dim dic As Object, a, i As Long, x, y, w()
Set dic = CreateObject("Scripting.Dictionary")
a = Range("a1").CurrentRegion.Resize(,2).Value
For i = 1 To UBound(a,1)
If Not dic.exists(a(i,1)) Then
dic.add a(i,1), Array(a(i,1), a(i,2))
Else
w = dic(a(i,1)) : ReDim Preserve w(UBound(w) + 1)
If w(UBound(w)) = "ECO Folder complete" Then
w(UBound(w)) = w(UBound(w) - 1) : w(UBound(w) - 1) = a(i,2)
Else
w(UBound(w)) = a(i,2)
End If
dic(a(i,1)) = w
End If
Next
x = dic.keys : y = dic.items : Set dic = Nothing : Erase a
With Range("d1")
.CurrentRegion.ClearContents
For i = 0 To UBound(y)
MsgBox UBound(x(i))
.Offset(i).Resize(,UBound(y(i)) + 1).Value = y(i)
Next
End With
End Sub

Croeg
11-17-2006, 09:10 PM
Okay,

Sorry for replying before you had a chance to answer.. I ran your last code and it stepped through the process. When it reached the end, the last box read 436. After selecting Okay, the error populated. So it seems to go into alarm once it reaches the end of my data.

Croeg

jindon
11-17-2006, 09:11 PM
Ah...
Can you try this...

Sub test()
Dim dic As Object, a, i As Long, y, w()
Set dic = CreateObject("Scripting.Dictionary")
a = Range("a1").CurrentRegion.Resize(,2).Value
For i = 1 To UBound(a,1)
If Not dic.exists(a(i,1)) Then
dic.add a(i,1), Array(a(i,1), a(i,2))
Else
w = dic(a(i,1)) : ReDim Preserve w(UBound(w) + 1)
If w(UBound(w)-1) = "ECO Folder complete" Then
w(UBound(w)) = w(UBound(w) - 1) : w(UBound(w) - 1) = a(i,2)
Else
w(UBound(w)) = a(i,2)
End If
dic(a(i,1)) = w
End If
Next
y = dic.items : Set dic = Nothing : Erase a
With Range("d1")
.CurrentRegion.ClearContents
For i = 0 To UBound(y)
.Offset(i).Resize(,UBound(y(i)) + 1).Value = y(i)
Next
End With
End Sub

Croeg
11-17-2006, 09:22 PM
Hi Jindon,

Okay, I ran the last code you posted and still get the same runtime error.


Croeg

jindon
11-17-2006, 09:35 PM
Is the result displyaing as you expected or not?

You mentioned that the error comes at the last item.

I don't know the reason why, but you can avoid the error by changing

For i = 0 To UBound(y) - 1

Croeg
11-17-2006, 09:41 PM
Jindon,

I made the change and it works perfectly....not sure why I was getting the error.:dunno Again thanks for all the help you've provided. You made my night !!!! :beerchug:


Croeg

Croeg
11-17-2006, 09:48 PM
Jindon,

I entered the change from you last post and it works perfectly !!!!! Not sure what was going on with the runtime error.:dunno Again, thanks so much for taking the time. You made my day. :beerchug:

Thanks,

Croeg

mdmackillop
11-18-2006, 03:37 AM
Hi Croeg,
It's always useful if you can post your actual layout with sample or dummy data. Code can get messed up by merged cells etc. It saves us making up spreadsheets to test our code on, and gets you a better result quicker.
Regards
MD

Croeg
11-18-2006, 11:46 AM
Hi mdmackillop,

Not to ask a dumb question but by "layout", do you mean creating a test sheet with code & attach that to my post?


Thanks,

Croeg

mdmackillop
11-18-2006, 12:18 PM
Not neccessarily with code.
Sheet layouts are rarely as simple as the data posted. I've seen merged cells, extra header rows, totals below the "last" entry etc., any or all of which can affect the running of the code. These can generally be handled without changing the layout; it clarifies things from the outset if we know what we're dealing with.
regards
MD

Croeg
11-18-2006, 12:55 PM
Hi mdmackillop,

Thanks for clarifying. :thumb


Croeg