help creating a marco please

[lsy]

name lx
A H1
A H1
A H2
A H3
B H1
B H2

name lx
A H1£¬H2£¬H3
B H1£¬H2
thx
excel2003

 

[RB Smissaert]

This is one way of doing it.
It presumes your original data is in columns A and B and the new data will
be dumped
in columns D and E.
If speed is important then I would use Olaf Schmidt's dhSortedDictionary,
which is in the
dll dhRichClient and that can be downloaded from here:
http://www.datenhaus.de/Downloads/dhRichClientDemo.zip

Sub test()

Dim i As Long
Dim x As Long
Dim arr
Dim coll1 As Collection
Dim coll2 As Collection
Dim coll3 As Collection
Dim collIDX As Collection
Dim lIDX As Long
Dim FR As Long
Dim LR As Long

LR = Cells(65536, 1).End(xlUp).Row
FR = Cells(LR, 1).End(xlUp).Row

arr = Range(Cells(FR, 1), Cells(LR, 2))

Set coll1 = New Collection
Set coll2 = New Collection
Set coll3 = New Collection
Set collIDX = New Collection

On Error Resume Next 'skipping duplicate keys
For i = 1 To UBound(arr)

'adding unique column 1 items A etc.
coll1.Add arr(i, 1), arr(i, 1)

'to keep track of the position of the first unique column 1 items
If Err.Number = 0 Then
x = x + 1
collIDX.Add x, arr(i, 1)
End If

'adding unique rows A,H1 etc.
coll2.Add arr(i, 1), arr(i, 1) & arr(i, 2)

'to keep track of unique column 2 items
coll3.Add arr(i, 2), arr(i, 1) & arr(i, 2)

Err.Clear 'needed as we do: If Err.Number = 0
Next i

On Error GoTo 0

ReDim arr(1 To coll1.Count, 1 To 2)

For i = 1 To coll1.Count
arr(i, 1) = coll1(i)
Next i

For i = 1 To coll2.Count
lIDX = collIDX(coll2(i))
If IsEmpty(arr(lIDX, 2)) Then
arr(lIDX, 2) = coll3(i)
Else
arr(lIDX, 2) = arr(lIDX, 2) & "£¬" & coll3(i)
End If
Next i

Range(Cells(4), Cells(UBound(arr), 5)) = arr

End Sub



RBS

 

[Don Guillett]

Maybe this?
Sub lineuplikeValues()
mc = 1' change to your column NUMBER
For i = Cells(Rows.Count, mc).End(xlUp).Row To 2 Step -1
If Cells(i, mc) = Cells(i - 1, mc) Then
Cells(i - 1, mc + 1).Value = _
Cells(i - 1, mc + 1) & ", " & Cells(i, mc + 1)
Rows(i).Delete
End If
Next
End Sub

 

[RB Smissaert]

As I needed this routine myself, I have worked it out a bit further to make
it more generic
(works both with 0-based and 1-based arrays and you can specify the group
column and the find column)
and also made a version based on cSortedDictionary and this will have both
the group column and the find
items sorted. The second version is about twice as fast if that matters.
Rather than concatenating the items in the second column I have put them in
different columns in a 2-D array
as that gives more flexibility.


Function GroupUniqueArrayElements(vArray As Variant, _
Optional lGroupColumn As Long = -1,
_
Optional lFindColumn As Long = -1)
As Variant

Dim i As Long
Dim x As Long
Dim coll1 As Collection
Dim coll2 As Collection
Dim coll3 As Collection
Dim collIDX As Collection
Dim arrColumns
Dim lIDX As Long
Dim lCols As Long
Dim LB As Long
Dim UB As Long
Dim LB2 As Long
Dim UB2 As Long
Dim arrResult

Set coll1 = New Collection
Set coll2 = New Collection
Set coll3 = New Collection
Set collIDX = New Collection

LB = LBound(vArray)
UB = UBound(vArray)
LB2 = LBound(vArray, 2)
UB2 = UBound(vArray, 2)

If lGroupColumn = -1 Then
lGroupColumn = LB2
End If

If lFindColumn = -1 Then
lFindColumn = UB2
End If

ReDim arrColumns(LB To UB) As Long

On Error Resume Next 'skipping duplicate keys

If LB = 0 Then
x = -1 'so collIDX will start with item 0
End If

For i = LB To UB

'adding unique column 1 items A etc.
coll1.Add vArray(i, lGroupColumn), vArray(i, lGroupColumn)

'to keep track of the position of the first unique column 1 items
If Err.Number = 0 Then
x = x + 1
collIDX.Add x, vArray(i, lGroupColumn)
End If

'so we can if a new item was added with Err.Number = 0
Err.Clear

'adding unique rows A,H1 etc.
coll2.Add vArray(i, lGroupColumn), _
vArray(i, lGroupColumn) & vArray(i, lFindColumn)

'to keep track of the number of column 2 items per unique column 1 item
If Err.Number = 0 Then
lIDX = collIDX.Item(vArray(i, lGroupColumn))
arrColumns(lIDX) = arrColumns(lIDX) + 1
If arrColumns(lIDX) > lCols Then
lCols = arrColumns(lIDX)
End If
End If

'to keep track of unique column 2 items
coll3.Add vArray(i, lFindColumn), vArray(i, lGroupColumn) & vArray(i,
lFindColumn)

Err.Clear 'needed as we do: If Err.Number = 0

Next i

On Error GoTo 0

ReDim arrResult(LB To coll1.Count - (1 - LB), LB2 To lCols + 1 - (1 -
LB2))

'fill in the unique (per column 1 item) column 2 items
For i = 1 To coll2.Count
lIDX = collIDX(coll2(i))
arrResult(lIDX, LB2) = arrResult(lIDX, LB2) + 1
arrResult(lIDX, arrResult(lIDX, LB2) + 1 - (1 - LB2)) = coll3(i)
Next i

'fill in the unique column 1 items
For i = 1 To coll1.Count
arrResult(i - (1 - LB), lGroupColumn) = coll1(i)
Next i

GroupUniqueArrayElements = arrResult

End Function

Function GroupUniqueArrayElementsSorted(vArray As Variant, _
Optional lGroupColumn As Long
= -1, _
Optional lFindColumn As Long
= -1) As Variant

Dim i As Long
Dim x As Long
Dim cSD1 As cSortedDictionary
Dim cSD2 As cSortedDictionary
Dim cSD3 As cSortedDictionary
Dim cSDIDX As cSortedDictionary
Dim arrColumns
Dim lIDX As Long
Dim lCols As Long
Dim LB As Long
Dim UB As Long
Dim LB2 As Long
Dim UB2 As Long
Dim arrResult

Set cSD1 = New cSortedDictionary
Set cSD2 = New cSortedDictionary
Set cSD3 = New cSortedDictionary
Set cSDIDX = New cSortedDictionary

LB = LBound(vArray)
UB = UBound(vArray)
LB2 = LBound(vArray, 2)
UB2 = UBound(vArray, 2)

If lGroupColumn = -1 Then
lGroupColumn = LB2
End If

If lFindColumn = -1 Then
lFindColumn = UB2
End If

ReDim arrColumns(LB To UB) As Long

If LB = 0 Then
x = -1 'so cSDIDX will start with item 0
End If

For i = LB To UB

'adding unique column 1 items A etc.
If cSD1.Exists(vArray(i, lGroupColumn)) = False Then
cSD1.Add vArray(i, lGroupColumn), vArray(i, lGroupColumn)
'to keep track of the position of the first unique column 1 items
x = x + 1
cSDIDX.Add vArray(i, lGroupColumn), x
End If

'adding unique rows A,H1 etc.
If cSD2.Exists(vArray(i, lGroupColumn) & vArray(i, lFindColumn)) = False
Then
cSD2.Add vArray(i, lGroupColumn) & vArray(i, lFindColumn), vArray(i,
lGroupColumn)

'to keep track of the number of column 2 items per unique column 1
item
lIDX = cSDIDX.Item(vArray(i, lGroupColumn))
arrColumns(lIDX) = arrColumns(lIDX) + 1
If arrColumns(lIDX) > lCols Then
lCols = arrColumns(lIDX)
End If
End If

'to keep track of unique column 2 items
If cSD3.Exists(vArray(i, lGroupColumn) & vArray(i, lFindColumn)) = False
Then
cSD3.Add vArray(i, lGroupColumn) & vArray(i, lFindColumn), vArray(i,
lFindColumn)
End If
Next i

On Error GoTo 0

ReDim arrResult(LB To cSD1.Count - (1 - LB), LB2 To lCols + 1 - (1 - LB2))

'fill in the unique (per column 1 item) column 2 items
For i = 1 To cSD2.Count
'+ LB is needed as IndexByKey is 0-based
lIDX = cSDIDX.IndexByKey(cSD2.ItemByIndex(i - 1)) + LB
arrResult(lIDX, LB2) = arrResult(lIDX, LB2) + 1
arrResult(lIDX, arrResult(lIDX, LB2) + 1 - (1 - LB2)) =
cSD3.ItemByIndex(i - 1)
Next i

'fill in the unique column 1 items
For i = 1 To cSD1.Count
arrResult(i - (1 - LB), lGroupColumn) = cSD1.ItemByIndex(i - 1)
Next i

GroupUniqueArrayElementsSorted = arrResult

End Function



RBS