Hi -
I'm trying to seperate out repeating info (last column has unique
data) and place them into a new line.
For example:
12345 CBB
12345 GGG
54321 PPP
99999 BBB
99999 AXZ
Would turn into
12345 CBB GGG
54321 PPP
99999 BBB AXZ
I've been trying to do this through a macro by reading in every row
and matching if the first column matches the second column then take
whats in the first column and place into the last column then delete
the first row.
But I havn't found a great way in code to do this yet. My first
problem is that I can't determine how many times the number would
repeat so I don't know how many columns to go over etc...
Thanks for any help on this,
- Tek
This should work. As written, it returns the data sorted in the order of
frequency of the numbers.
As written, the Combine macro will act on "Selection" (actually, you only have
to select the first column of data) and place the results starting in A20.
Both of those parameters could be easily changed to meet your requirements.
===============================================
Option Explicit
Sub Combine()
Dim c As Range
Dim rg As Range
Dim rDest As Range
Dim sSerialNums As Variant
Dim aRes()
Dim i As Long, j As Long
'can determine rg to check in many ways
'this is just one:
Set rg = Selection.Resize(Selection.Rows.Count, 1)
'Again, many ways to determine where to put the results
Set rDest = Range("A20")
sSerialNums = UniqueCount(rg)
ReDim aRes(0 To UBound(sSerialNums, 2) - 1, 0 To sSerialNums(1, 1))
For i = 0 To UBound(sSerialNums, 2) - 1
aRes(i, 0) = sSerialNums(0, i + 1)
j = 1
Do Until j > sSerialNums(1, i + 1)
For Each c In rg
If c.Value = aRes(i, 0) Then
aRes(i, j) = c.Offset(0, 1)
j = j + 1
End If
Next c
Loop
Next i
For i = 0 To UBound(aRes)
For j = 0 To UBound(aRes, 2)
rDest(i + 1, j + 1) = aRes(i, j)
Next j
Next i
End Sub
'--------------------------------------------
Function UniqueCount(rg As Range)
'Returns a horizontal two dimensional
' array of unique words and count
Dim cWordList As Collection
Dim Str As String
Dim sRes() As Variant
Dim i As Long, j As Long
Dim c As Range
'get list of unique words
Set cWordList = New Collection
On Error Resume Next
For Each c In rg
cWordList.Add c.Value, CStr(c.Value)
Next c
On Error GoTo 0
ReDim sRes(0 To 1, 1 To cWordList.Count)
For i = 1 To cWordList.Count
sRes(0, i) = cWordList(i)
Next i
'get word count for each word
For i = 1 To UBound(sRes, 2)
sRes(1, i) = Application.WorksheetFunction.CountIf(rg, sRes(0, i))
Next i
'Reverse sorting order if you want the words alphabetically
'without respect to the counts
'Sort words alphabetically A-Z
BubbleSortX sRes, 0, True
'then sort by Count highest to lowest
BubbleSortX sRes, 1, False
UniqueCount = sRes
End Function
'--------------------------------------------------------------
Private Sub BubbleSortX(TempArray As Variant, d As Long, _
bSortDirection As Boolean)
'bSortDirection = True means sort ascending
'bSortDirection = False means sort descending
Dim Temp1 As Variant, Temp2
Dim i As Long
Dim NoExchanges As Boolean
Dim Exchange As Boolean
' Loop until no more "exchanges" are made.
Do
NoExchanges = True
' Loop through each element in the array.
For i = 1 To UBound(TempArray, 2) - 1
' If the element is greater/less than the element
' following it, exchange the two elements.
Exchange = TempArray(d, i) < TempArray(d, i + 1)
If bSortDirection = True Then Exchange = _
TempArray(d, i) > TempArray(d, i + 1)
If Exchange Then
NoExchanges = False
Temp1 = TempArray(0, i)
Temp2 = TempArray(1, i)
TempArray(0, i) = TempArray(0, i + 1)
TempArray(1, i) = TempArray(1, i + 1)
TempArray(0, i + 1) = Temp1
TempArray(1, i + 1) = Temp2
End If
Next i
Loop While Not (NoExchanges)
End Sub
======================================
--ron
