Merge/consolidate text cells based on unique keys ?

X

x13

Hi all.

I hope someone can help me out.

I have an Excel worksheet with 2 columns: 'Client #' and 'Invoice #'.

Every time the accounting dept. generates an invoice, a new row is
added in this worksheet.
Obviously this is chronological not per Client #.

But for the sake of simplicity, let's assume the worksheet is already
sorted by Client #, like so:

A B

Client # Invoice #

231 5929
231 4358
231 2185
231 6234
464 1166
464 1264
464 3432
464 1720
464 9747
791 1133
791 4930
791 5496
791 6291
989 8681
989 3023
989 7935
989 8809
989 8873

My goal is to achieve this:

Client # Invoice #

231 5929, 4358, 2185, 6234
464 1166, 1264, 3432, 1720, 9747
791 1133, 4930, 5496, 6291
989 8681, 3023, 7935, 8809, 8873


In order to create a (Word) mail-merge, where I can write to each
Client:


"Dear ABC,

You have the following invoices are still open: <column B from the
optimised version>..."


Anyone have an idea how to achieve this without external software or
VB programming?

Any help greatly appreciated.
==
M.T.
 
J

James Ravenswood

Hi all.

I hope someone can help me out.

I have an Excel worksheet with 2 columns: 'Client #' and 'Invoice #'.

Every time the accounting dept. generates an invoice, a new row is
added in this worksheet.
Obviously this is chronological not per Client #.

But for the sake of simplicity, let's assume the worksheet is already
sorted by Client #, like so:

   A             B

Client #        Invoice #

231     5929
231     4358
231     2185
231     6234
464     1166
464     1264
464     3432
464     1720
464     9747
791     1133
791     4930
791     5496
791     6291
989     8681
989     3023
989     7935
989     8809
989     8873

My goal is to achieve this:

Client #        Invoice #

231     5929, 4358, 2185, 6234
464     1166, 1264, 3432, 1720, 9747
791     1133, 4930, 5496, 6291
989     8681, 3023, 7935, 8809, 8873

In order to create a (Word) mail-merge, where I can write to each
Client:

"Dear ABC,

You have the following invoices are still open: <column B from the
optimised version>..."

Anyone have an idea how to achieve this without external software or
VB programming?

Any help greatly appreciated.
==
M.T.
Click to expand...



Until you get a non-VB solution, here is a VBA solution:


Sub ReOrganize()
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
Dim cl As Collection
Set cl = New Collection
Dim i As Long, j As Long, k As Long, l As Long
Dim jj As Long
j = 1
k = s1.Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
For i = 1 To k
v = s1.Cells(i, 1).Value
Err.Clear
cl.Add v, CStr(v)
If Err.Number = 0 Then
s2.Cells(j, 1).Value = v
jj = 2
For l = i To k
If s1.Cells(l, 1).Value = v Then
s2.Cells(j, jj).Value = s1.Cells(l, 2).Value
jj = jj + 1
End If
Next
j = j + 1
End If
Next
End Sub



Macros are very easy to install and use:

1. ALT-F11 brings up the VBE window
2. ALT-I
ALT-M opens a fresh module
3. paste the stuff in and close the VBE window

If you save the workbook, the macro will be saved with it.

To remove the macro:

1. bring up the VBE window as above
2. clear the code out
3. close the VBE window

To use the macro from Excel:

1. ALT-F8
2. Select the macro
3. Touch RUN

To learn more about macros in general, see:

http://www.mvps.org/dmcritchie/excel/getstarted.htm
 
X

x13

Hi James.

First thanks for your help!

You're right. That cell manipulations I require -- albeit simple if
done manually -- are a bit too intricate for the available built-in
functions.
So VB is fine.

On the first run I got a 'Subscript out of range' error on 'Set s2 =
Sheets("Sheet2")' because that worksheet didn't exist. Obviously.
Your module works fine, but it creates a table of results of variable
width, whereas I need to begin -- and end -- with 2 columns.
The second column must be a concatenation, but your module creates as
many extra columns as the client has invoices.

This complicates things for the next step: using Sheet2 as input for a
Word mail merge.
Since I can't know it advance how wide the output table will be, I'd
have to make the selection unnecessarily wide.
Plus I can't identify multiple columns using a single column header.

Not to impose, but could (you tell me how to ) modify your module so
that each new invoice number is concatenated into the second column?
If I have the 2 columns to work with then I can figure out the rest.


Thanks!
M.T.
 
R

Ron Rosenfeld

Hi all.

I hope someone can help me out.

I have an Excel worksheet with 2 columns: 'Client #' and 'Invoice #'.

Every time the accounting dept. generates an invoice, a new row is
added in this worksheet.
Obviously this is chronological not per Client #.

But for the sake of simplicity, let's assume the worksheet is already
sorted by Client #, like so:

A B

Client # Invoice #

231 5929
231 4358
231 2185
231 6234
464 1166
464 1264
464 3432
464 1720
464 9747
791 1133
791 4930
791 5496
791 6291
989 8681
989 3023
989 7935
989 8809
989 8873

My goal is to achieve this:

Client # Invoice #

231 5929, 4358, 2185, 6234
464 1166, 1264, 3432, 1720, 9747
791 1133, 4930, 5496, 6291
989 8681, 3023, 7935, 8809, 8873


In order to create a (Word) mail-merge, where I can write to each
Client:


"Dear ABC,

You have the following invoices are still open: <column B from the
optimised version>..."


Anyone have an idea how to achieve this without external software or
VB programming?

Any help greatly appreciated.
==
M.T.
Click to expand...

Here's another VB Solution. The data is sorted within the sub, so does not have to be sorted first. And I think the output is in the format you specify, but you may want to modify the location.

======================
Option Explicit
Sub MakeList()
Dim vData As Variant
Dim vRes() As Variant
Dim vTemp As Variant
Dim lRows As Long
Dim i As Long, j As Long
Dim coll As Collection 'to get unique list of ID's

'Rows of data:
lRows = Range("A1", Cells(Cells.Rows.Count, "A").End(xlUp)).Rows.Count

'Read data into a VBA variable
vData = Range("A1", Cells(Cells.Rows.Count, "B").End(xlUp)) _
.Offset(rowoffset:=1).Resize(rowsize:=lRows - 1)

'Sort it
vData = WorksheetFunction.Transpose(vData)
MyQuickSort_Single vData, LBound(vData, 2), UBound(vData, 2), 1, True

'get unique list of ID's
Set coll = New Collection
On Error Resume Next
For i = 1 To UBound(vData, 2)
coll.Add vData(1, i), CStr(vData(1, i))
Next i
On Error GoTo 0

'set up results array
ReDim vRes(1 To 2, 1 To coll.Count)
i = 1
For j = 1 To coll.Count
vRes(1, j) = coll(j)
Do
vRes(2, j) = vRes(2, j) & ", " & vData(2, i)
i = i + 1
If i > UBound(vData, 2) Then Exit Do
Loop Until vData(1, i) <> coll(j)
vRes(2, j) = Mid(vRes(2, j), 3)
Next j

vRes = WorksheetFunction.Transpose(vRes)

Range("F1", Cells(coll.Count, "G")) = vRes


End Sub

' ***********************************************
' Multidimensional Array sorted on a single dimensions
' ***********************************************
Private Sub MyQuickSort_Single(ByRef SortArray As Variant, ByVal First As Long, ByVal Last As Long, _
ByVal PrimeSort As Integer, ByVal Ascending As Boolean)
Dim Low As Long, High As Long
Dim Temp As Variant, List_Separator1 As Variant
Dim i As Long
Dim TempArray() As Variant
ReDim TempArray(UBound(SortArray, 1))
Low = First
High = Last
List_Separator1 = SortArray(PrimeSort, (First + Last) / 2)
Do
If Ascending = True Then
Do While (SortArray(PrimeSort, Low) < List_Separator1)
Low = Low + 1
Loop
Do While (SortArray(PrimeSort, High) > List_Separator1)
High = High - 1
Loop
Else
Do While (SortArray(PrimeSort, Low) > List_Separator1)
Low = Low + 1
Loop
Do While (SortArray(PrimeSort, High) < List_Separator1)
High = High - 1
Loop
End If
If (Low <= High) Then
For i = LBound(SortArray, 1) To UBound(SortArray, 1)
TempArray(i) = SortArray(i, Low)
Next
For i = LBound(SortArray, 1) To UBound(SortArray, 1)
SortArray(i, Low) = SortArray(i, High)
Next
For i = LBound(SortArray, 1) To UBound(SortArray, 1)
SortArray(i, High) = TempArray(i)
Next
Low = Low + 1
High = High - 1
End If
Loop While (Low <= High)
If (First < High) Then MyQuickSort_Single SortArray, First, High, PrimeSort, Ascending
If (Low < Last) Then MyQuickSort_Single SortArray, Low, Last, PrimeSort, Ascending
End Sub
==============================
 
R

Ron Rosenfeld

Hi all.

I hope someone can help me out.

I have an Excel worksheet with 2 columns: 'Client #' and 'Invoice #'.

Every time the accounting dept. generates an invoice, a new row is
added in this worksheet.
Obviously this is chronological not per Client #.

But for the sake of simplicity, let's assume the worksheet is already
sorted by Client #, like so:

A B

Client # Invoice #

231 5929
231 4358
231 2185
231 6234
464 1166
464 1264
464 3432
464 1720
464 9747
791 1133
791 4930
791 5496
791 6291
989 8681
989 3023
989 7935
989 8809
989 8873

My goal is to achieve this:

Client # Invoice #

231 5929, 4358, 2185, 6234
464 1166, 1264, 3432, 1720, 9747
791 1133, 4930, 5496, 6291
989 8681, 3023, 7935, 8809, 8873


In order to create a (Word) mail-merge, where I can write to each
Client:


"Dear ABC,

You have the following invoices are still open: <column B from the
optimised version>..."


Anyone have an idea how to achieve this without external software or
VB programming?

Any help greatly appreciated.
==
M.T.
Click to expand...

It occurs to me that you might want to also have the invoices be listed in sorted order. If that is the case, try this version which sorts on both dimensions before creating the result:

====================
Option Explicit
Sub MakeList()
Dim vData As Variant
Dim vRes() As Variant
Dim vTemp As Variant
Dim lRows As Long
Dim i As Long, j As Long
Dim coll As Collection 'to get unique list of ID's

'Rows of data:
lRows = Range("A1", Cells(Cells.Rows.Count, "A").End(xlUp)).Rows.Count

'Read data into a VBA variable
vData = Range("A1", Cells(Cells.Rows.Count, "B").End(xlUp)) _
.Offset(rowoffset:=1).Resize(rowsize:=lRows - 1)

'Sort it
vData = WorksheetFunction.Transpose(vData)
MyQuickSort_Two vData, LBound(vData, 2), UBound(vData, 2), 1, 2, True

'get unique list of ID's
Set coll = New Collection
On Error Resume Next
For i = 1 To UBound(vData, 2)
coll.Add vData(1, i), CStr(vData(1, i))
Next i
On Error GoTo 0

'set up results array
ReDim vRes(1 To 2, 1 To coll.Count)
i = 1
For j = 1 To coll.Count
vRes(1, j) = coll(j)
Do
vRes(2, j) = vRes(2, j) & ", " & vData(2, i)
i = i + 1
If i > UBound(vData, 2) Then Exit Do
Loop Until vData(1, i) <> coll(j)
vRes(2, j) = Mid(vRes(2, j), 3)
Next j

vRes = WorksheetFunction.Transpose(vRes)

With Range("F1", Cells(coll.Count, "G"))
.Value = vRes
.EntireColumn.AutoFit
End With

End Sub
' ************************************************
' Multidimensional Array sort on 2 dimensions
' ************************************************
Sub MyQuickSort_Two(ByRef SortArray As Variant, ByVal First As Long, ByVal Last As Long, _
ByVal PrimeSort As Integer, ByVal SecSort As Integer, ByVal Ascending As Boolean)
Dim Low As Long, High As Long
Dim Temp As Variant
Dim List_Separator1 As Variant, List_Separator2 As Variant
Dim TempArray() As Variant
Dim i As Long
ReDim TempArray(UBound(SortArray, 1))
Low = First
High = Last
List_Separator1 = SortArray(PrimeSort, (First + Last) / 2)
List_Separator2 = SortArray(SecSort, (First + Last) / 2)
Do
If Ascending = True Then
Do While (SortArray(PrimeSort, Low) < List_Separator1) Or _
((SortArray(PrimeSort, Low) = List_Separator1) And (SortArray(SecSort, Low) < List_Separator2))
Low = Low + 1
Loop
Do While (SortArray(PrimeSort, High) > List_Separator1) Or _
((SortArray(PrimeSort, High) = List_Separator1) And (SortArray(SecSort, High) > List_Separator2))
High = High - 1
Loop
Else
Do While (SortArray(PrimeSort, Low) > List_Separator1) Or _
((SortArray(PrimeSort, Low) = List_Separator1) And (SortArray(SecSort, Low) > List_Separator2))
Low = Low + 1
Loop
Do While (SortArray(PrimeSort, High) < List_Separator1) Or _
((SortArray(PrimeSort, High) = List_Separator1) And (SortArray(SecSort, High) < List_Separator2))
High = High - 1
Loop
End If
If (Low <= High) Then
For i = LBound(SortArray, 1) To UBound(SortArray, 1)
TempArray(i) = SortArray(i, Low)
Next
For i = LBound(SortArray, 1) To UBound(SortArray, 1)
SortArray(i, Low) = SortArray(i, High)
Next
For i = LBound(SortArray, 1) To UBound(SortArray, 1)
SortArray(i, High) = TempArray(i)
Next
Low = Low + 1
High = High - 1
End If
Loop While (Low <= High)
If (First < High) Then MyQuickSort_Two SortArray, First, High, PrimeSort, SecSort, Ascending
If (Low < Last) Then MyQuickSort_Two SortArray, Low, Last, PrimeSort, SecSort, Ascending
End Sub
=====================================
 
X

x13

Wow!

Thanks to both James and Ron for your assistance.
The last version of Ron's solution has solved my problem.

PS: The placement of the resulting table seems arbitrary (not relative
to cursor position when running the macro), but I can live with it. ;)

M.T.
 
R

Ron Rosenfeld

Wow!

Thanks to both James and Ron for your assistance.
The last version of Ron's solution has solved my problem.

PS: The placement of the resulting table seems arbitrary (not relative
to cursor position when running the macro), but I can live with it. ;)

M.T.
Click to expand...


Glad to help. Thanks for the feedback.

With regard to the table placement, that is arbitrary but defined within the macro.

These lines near the end define the placement of the resulting table:

---------
With Range("F1", Cells(coll.Count, "G"))
.Value = vRes
.EntireColumn.AutoFit
End With
-------

You need to define a range that is the same size and shape of the resultant vRes array.

I arbitrarily chose to put it into F1:Gn where n is the number of rows in the vRes array, and should be the same as the number of entries in the coll collection.

But you can put it anyplace. Just be sure that you are only defining two columns in your resultant range.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Outlook crashes with Outlook connector 2002 0
Outlook connector crashes outlook 0

Top