ExcelBanter - View Single Post

Ron Rosenfeld

On Sat, 15 Nov 2008 12:06:41 -0800 (PST), wrote:

I have a 60,000 long series of items that correspond with a range of
values. I need to automatically transpose the corresponding values
so
that they can be combined into one cell.

Here's what I have:

A B
1.2101R 1992
1.2101R 1993
1.2101R 1994
1.2101R 1995
1.2102G 1986
1.2102G 1987
10.1101G 1963
10.1101G 1964
10.1101G 1965
10.1101G 1966
10.1101G 1967
10.1101G 1968

Here's what I need

A B C D E
1.2101R 1992 1993 1994 1995
1.2102G 1986 1987
10.1101G 1963 1964 1965 1966 1967 1968

As you can see there are different quantities with each item.

In order to combine them into one cell, you are going to probably need a VBA
Macro. With 60,000 items, I suspect my contribution will take a while to run,
but it might be sufficient for you.

To enter this macro, <alt-F11 opens the VB Editor. Ensure your project is
highlighted in the project explorer window, then Insert/Module and paste the
code below into the window that opens.

Since I don't know the setup of your worksheet, I assumed that your items and
values were listed in columns A & B, and that you have selected some cell
within the table.

I also chose to begin the results showing in F2, and to continue down below
that. You should be able to change these appropriately.

In any event, it should give you a start.

After you have entered the Macro, and also selected a cell within your table,
<alt-F8 opens the macro dialog box. Select the Macro and <RUN.

================================================
Option Compare Text
Option Explicit
Sub CombineData()
Dim rSrc As Range, rSrcFirstCol As Range
Dim rDest As Range
Dim c As Range
Dim UniqueItems As Variant
Dim i As Long, j As Long
Dim lStartRow As Long

'Many ways to set up the range of data
Set rSrc = Selection.CurrentRegion
Set rSrcFirstCol = rSrc.Resize(columnsize:=1)
Set rDest = Range("F2")
'get number of unique items and
'number of values per item
UniqueItems = UniqueCount(rSrcFirstCol)
rDest.Resize(UBound(UniqueItems, 2), 1).ClearContents

For i = 1 To UBound(UniqueItems, 2)
rDest(i, 1) = UniqueItems(0, i)
For j = 1 To UniqueItems(1, i)
For Each c In rSrcFirstCol
If c.Value = UniqueItems(0, i) Then
rDest(i, 1) = rDest(i, 1) & " " & c.Offset(0, 1).Value
j = j + 1
End If
Next c
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

'sort by Count highest to lowest
BubbleSortX sRes, 1, False

'Sort words alphabetically A-Z
BubbleSortX sRes, 0, True

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