Re-arrange data set for mailing list

G

gato88

New Member
Joined
Feb 10, 2014
Messages
25
Hi appreciate if you could assist:

Current data set
Branch
Account Number
Customer NumberCustomer NameClass
200012345101JOEA
200034590101JOEA
200023581312PETERA
200032510511HARRYA
200036711511HARRYA
200015231511HARRYA
200052315789PAULA
etc...

<tbody>
</tbody>

Required data structure (in view of a mailing list):
BranchCustomer NumberCustomer NameAccount 1Class 1Account 2Class 2Account 3Class 3
2000101JOE12345A34590A
2000312PETER23581A
2000511HARRY32510A36711A15231A
2000789PAUL52315A
etc...

<tbody>
</tbody>












As the mailing list will grab the data under each header for each row (based on the customer number), I need to re-assign the data to the individual headers.
As per the sample above, the data will be sorted by customer number.
I have a long list of 500 customer numbers each with an average of 2 accounts, so I need to find an efficient solution to automate this task.

Appreciate your kind assistance. Thanks!
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
Sort by date Sort by votes
Try this for Results on sheet 2.
Code: 
[COLOR="Navy"]Sub[/COLOR] MG17May57
[COLOR="Navy"]Dim[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object
Ray = ActiveSheet.Range("A1").CurrentRegion.Resize(, 5)
ReDim nRay(1 To UBound(Ray, 1), 1 To 5)
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(Ray, 1)
    [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Join(Application.Index(Ray, n, Array(1, 3, 4)))) [COLOR="Navy"]Then[/COLOR]
        c = c + 1
        nRay(c, 1) = Ray(n, 1)
        nRay(c, 2) = Ray(n, 3)
        nRay(c, 3) = Ray(n, 4)
        nRay(c, 4) = Ray(n, 2)
        nRay(c, 5) = Ray(n, 5)
        Dic.Add Join(Application.Index(Ray, n, Array(1, 3, 4))), Array(c, 5, 1)
[COLOR="Navy"]Else[/COLOR]
    Q = Dic.Item(Join(Application.Index(Ray, n, Array(1, 3, 4))))
         Q(1) = Q(1) + 2
         Q(2) = Q(2) + 1
         
         [COLOR="Navy"]If[/COLOR] UBound(nRay, 2) <= Q(1) [COLOR="Navy"]Then[/COLOR] ReDim Preserve nRay(1 To UBound(Ray, 1), 1 To Q(1))
         nRay(Q(0), Q(1) - 1) = Ray(n, 2)
         nRay(Q(0), Q(1)) = Ray(n, 5)
         nRay(1, Q(1) - 1) = "Account " & Q(2)
         nRay(1, Q(1)) = "Class" & Q(2)
         oMax = Application.Max(oMax, Q(1))
    Dic.Item(Join(Application.Index(Ray, n, Array(1, 3, 4)))) = Q
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] n
'[COLOR="Green"][B][/B][/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, oMax)
    .Value = nRay
    .Borders.Weight = 2
    .Columns.AutoFit
    .Sort _
    Key1:=.Parent.Range("B1"), Header:=xlYes
[COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
AWSOME! Thanks Mick. Just what I was after.

Just one minor thing I found in the output sheet.
The first two dynamic column headers did not update in the output sheet, showing the original header names instead:
Account Number (instead of Account1) and Class (instead of Class1)
 
Upvote 0
Try this:-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG19May02
[COLOR="Navy"]Dim[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object
Ray = ActiveSheet.Range("A1").CurrentRegion.Resize(, 5)
ReDim nRay(1 To UBound(Ray, 1), 1 To 5)
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(Ray, 1)
    [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Join(Application.Index(Ray, n, Array(1, 3, 4)))) [COLOR="Navy"]Then[/COLOR]
        c = c + 1
         nRay(c, 1) = Ray(n, 1)
         nRay(c, 2) = Ray(n, 3)
         nRay(c, 3) = Ray(n, 4)
         nRay(c, 4) = Ray(n, 2)
         nRay(c, 5) = Ray(n, 5)
     [COLOR="Navy"]If[/COLOR] n = 1 [COLOR="Navy"]Then[/COLOR]
        nRay(c, 4) = "Account 1"
        nRay(c, 5) = "Class 1"
      [COLOR="Navy"]End[/COLOR] If
        Dic.Add Join(Application.Index(Ray, n, Array(1, 3, 4))), Array(c, 5, 1)
[COLOR="Navy"]Else[/COLOR]
    Q = Dic.Item(Join(Application.Index(Ray, n, Array(1, 3, 4))))
         Q(1) = Q(1) + 2
         Q(2) = Q(2) + 1
         
         [COLOR="Navy"]If[/COLOR] UBound(nRay, 2) <= Q(1) [COLOR="Navy"]Then[/COLOR] ReDim Preserve nRay(1 To UBound(Ray, 1), 1 To Q(1))
         nRay(Q(0), Q(1) - 1) = Ray(n, 2)
         nRay(Q(0), Q(1)) = Ray(n, 5)
         nRay(1, Q(1) - 1) = "Account " & Q(2)
         nRay(1, Q(1)) = "Class" & Q(2)
         oMax = Application.Max(oMax, Q(1))
    Dic.Item(Join(Application.Index(Ray, n, Array(1, 3, 4)))) = Q
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] n
'[COLOR="Green"][B][/B][/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, oMax)
    .Value = nRay
    .Borders.Weight = 2
    .Columns.AutoFit
    .Sort _
    Key1:=.Parent.Range("B1"), Header:=xlYes
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
MickG said:
Try this:-

Code: 
Regards Mick[/QUOTE]

Great! Thanks Mick. Fantastic job!
I need to add another field to the table, called "Rating" as per below.
This will create a new dynamic field in the output sheet using similar logic as what you created. 
Can you please assist? :confused:


[B]Current data set[/B]
[TABLE="class: cms_table_grid, width: 500"]
<tbody>[TR]
[TD]Branch[/TD]
[TD]Account Number[/TD]
[TD]Customer Number[/TD]
[TD]Customer Name[/TD]
[TD]Class[/TD]
[TD]Rating[/TD]
[/TR]
[TR]
[TD]2000[/TD]
[TD]12345[/TD]
[TD]101[/TD]
[TD]JOE[/TD]
[TD]A[/TD]
[TD]10[/TD]
[/TR]
[TR]
[TD]2000[/TD]
[TD]34590[/TD]
[TD]101[/TD]
[TD]JOE[/TD]
[TD]A[/TD]
[TD]11[/TD]
[/TR]
[TR]
[TD]2000[/TD]
[TD]23581[/TD]
[TD]312[/TD]
[TD]PETER[/TD]
[TD]A[/TD]
[TD]12[/TD]
[/TR]
[TR]
[TD]2000[/TD]
[TD]32510[/TD]
[TD]511[/TD]
[TD]HARRY[/TD]
[TD]A[/TD]
[TD]15[/TD]
[/TR]
[TR]
[TD]2000[/TD]
[TD]36711[/TD]
[TD]511[/TD]
[TD]HARRY[/TD]
[TD]A[/TD]
[TD]23[/TD]
[/TR]
[TR]
[TD]2000[/TD]
[TD]15231[/TD]
[TD]511[/TD]
[TD]HARRY[/TD]
[TD]A[/TD]
[TD]31[/TD]
[/TR]
[TR]
[TD]2000[/TD]
[TD]52315[/TD]
[TD]789[/TD]
[TD]PAUL[/TD]
[TD]A[/TD]
[TD]34[/TD]
[/TR]
[TR]
[TD]etc...[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

 
[B]Required data structure (in view of a mailing list):[/B]
[TABLE="class: cms_table_grid, width: 500, align: left"]
<tbody>[TR]
[TD]Branch[/TD]
[TD]Customer Number[/TD]
[TD]Customer Name[/TD]
[TD]Account 1[/TD]
[TD]Class 1[/TD]
[TD]Rating 1[/TD]
[TD]Account 2[/TD]
[TD]Class 2[/TD]
[TD]Rating 2[/TD]
[TD]Account 3[/TD]
[TD]Class 3[/TD]
[TD]Rating
3[/TD]
[/TR]
[TR]
[TD]2000[/TD]
[TD]101[/TD]
[TD]JOE[/TD]
[TD]12345[/TD]
[TD]A[/TD]
[TD]10[/TD]
[TD]34590[/TD]
[TD]A[/TD]
[TD]11[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]2000[/TD]
[TD]312[/TD]
[TD]PETER[/TD]
[TD]23581[/TD]
[TD]A[/TD]
[TD]12[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]2000[/TD]
[TD]511[/TD]
[TD]HARRY[/TD]
[TD]32510[/TD]
[TD]A[/TD]
[TD]15[/TD]
[TD]36711[/TD]
[TD]A[/TD]
[TD]23[/TD]
[TD]15231[/TD]
[TD]A[/TD]
[TD]31[/TD]
[/TR]
[TR]
[TD]2000[/TD]
[TD]789[/TD]
[TD]PAUL[/TD]
[TD]52315[/TD]
[TD]A[/TD]
[TD]34[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]etc...[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
Click to expand...
 
Upvote 0
Try this for results on sheet2
Code: 
[COLOR="Navy"]Sub[/COLOR] MG21May49
[COLOR="Navy"]Dim[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Q [COLOR="Navy"]As[/COLOR] Variant, oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object
Ray = ActiveSheet.Range("A1").CurrentRegion.Resize(, 6)
ReDim nRay(1 To UBound(Ray, 1), 1 To 6)
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(Ray, 1)
    [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Join(Application.Index(Ray, n, Array(1, 3, 4)))) [COLOR="Navy"]Then[/COLOR]
        c = c + 1
         nRay(c, 1) = Ray(n, 1)
         nRay(c, 2) = Ray(n, 3)
         nRay(c, 3) = Ray(n, 4)
         nRay(c, 4) = Ray(n, 2)
         nRay(c, 5) = Ray(n, 5)
         nRay(c, 6) = Ray(n, 6)
     [COLOR="Navy"]If[/COLOR] n = 1 [COLOR="Navy"]Then[/COLOR]
        nRay(c, 4) = "Account 1"
        nRay(c, 5) = "Class 1"
        nRay(c, 6) = "Rating 1"
      [COLOR="Navy"]End[/COLOR] If
        Dic.Add Join(Application.Index(Ray, n, Array(1, 3, 4))), Array(c, 6, 1)
[COLOR="Navy"]Else[/COLOR]
    Q = Dic.Item(Join(Application.Index(Ray, n, Array(1, 3, 4))))
         Q(1) = Q(1) + 3
         Q(2) = Q(2) + 1
         
         [COLOR="Navy"]If[/COLOR] UBound(nRay, 2) <= Q(1) [COLOR="Navy"]Then[/COLOR] ReDim Preserve nRay(1 To UBound(Ray, 1), 1 To Q(1))
         nRay(Q(0), Q(1) - 2) = Ray(n, 2)
         nRay(Q(0), Q(1) - 1) = Ray(n, 5)
         nRay(Q(0), Q(1)) = Ray(n, 6)
         nRay(1, Q(1) - 2) = "Account " & Q(2)
         nRay(1, Q(1) - 1) = "Class" & Q(2)
         nRay(1, Q(1)) = "Rating" & Q(2)
         oMax = Application.Max(oMax, Q(1))
    Dic.Item(Join(Application.Index(Ray, n, Array(1, 3, 4)))) = Q
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] n
'[COLOR="Green"][B][/B][/COLOR]
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(c, oMax)
    .Value = nRay
    .Borders.Weight = 2
    .Columns.AutoFit
    .Sort _
    Key1:=.Parent.Range("B1"), Header:=xlYes
[COLOR="Navy"]End[/COLOR] With


[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question
EXTRAPOLATE DATA FROM A TABLE!!!
Replies
6
Views
966
JamesCanale
JamesCanale
T
  • Question
MATCH or VLOOKUP? or something different
Replies
3
Views
663
cerfani
C
B
  • Question
VBA Code to break list into separate emails worked on Friday - Broken today???
Replies
0
Views
643
bcurrey
B
X
  • Question
Compiling data from different worksheets based on a criteria
2
Replies
14
Views
877
mumps
mumps
R
  • Question
VBA Mail a row to each person in a range
Replies
5
Views
939
Macropod
Macropod

Forum statistics

Threads
1,214,620
Messages
6,120,559
Members
448,970
Latest member
kennimack

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top