Solved: Data for Mail Merge to be consolidated

[varundhamija]

Hi... Need immediate and urgent help,

Need to create a Subtotal for taking data into Mail Merge...

I basically need to subtotal/consolidate my data first, so that for the same Deductee, the information gets consolidated into 1 row, so that I can use Mail Merge to take whatever information that I need into the Word Form. Since Mail merge goes record by record that is why I need this info into 1 row. The other problem is that they are multiple sets of data for same deductee (can be 10 or even more?) any thoughts on how to counter this?

Given below is pre and post (required) state of data. See attachement.

Thanks for all the help.

[mdmackillop]

Hi
Welcome to VBAX.
Try the following. The code requires a reference to Microsoft Scripting Runtime.
Regards
MD

[vba]
Option Explicit
Sub Allocate()
Dim Cel As Range, Co As Range, i As Long, j As Long, k As Long
Dim Tot As Long
Dim Dic, a, FirstAddress As String, c As Range
Set Co = Range([A2], [A2].End(xlDown))
Set Dic = CreateObject("Scripting.Dictionary")
For Each Cel In Co
On Error Resume Next
Dic.Add Cel.Text, Cel
Next
Tot = 0
a = Dic.keys
j = 2
For i = 0 To Dic.Count - 1
j = j + 1
Sheets("Sheet2").Cells(j, 1) = a(i)
FirstAddress = ""
With Sheets("Sheet1").Columns("A")
Set c = .Find(a(i), LookIn:=xlValues)
If Not c Is Nothing Then
FirstAddress = c.Address
k = -1
Do
k = k + 1
If k > Tot Then Tot = k
c.Range("B1:F1").Copy Sheets("Sheet2").Cells(j, 2 + 5 * k)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
Next
'Set titles
Sheets("Sheet1").Range("A1:F1").Copy Sheets("Sheet2").[A2]
Sheets("Sheet2").Activate
Sheets("Sheet2").Range("B2:F2").AutoFill _
Destination:=Range(Cells(2, 2), Cells(2, 6 + 5 * Tot)), Type:=xlFillDefault
'Set numbering
Range("B1").Select
ActiveCell.FormulaR1C1 = "Set 1"
With Range("B1:F1")
.MergeCells = True
.Interior.ColorIndex = 6
.AutoFill Destination:=Range(Cells(1, 2), Cells(1, 6 + 5 * Tot)), Type:=xlFillDefault
End With
End Sub
[/vba]

[varundhamija]

This works like a dream, you're a Wiz. Thanks so much!

[varundhamija]

Hey MD,

Change never ceases in this world, I need some more help to be able to extend this to another file. The changes are:

1. The fixed portion has extended (A:J)
2. Variable portion is (K:S)
3. Needs to go to sheet 2 in a similar fashion, but last step has to be the addition of a spellnumber macro in cell after last cell [See Column AL in Sheet 2 of attached file]

Once again appreciate your help, wish I knew coding well enough to change this myself.

Thanks... Varun D

[mdmackillop]

The main purpose of this site is to provide assistance to those learning VBA or require assistance with their coding, not to provide full solutions for free. If you can post your modifications with and a note of your problems, we'll try to assist.
Regards
MD

[varundhamija]

Thanks, anyways. I'll keep that in mind.

[varundhamija]

Hey MD, took your advice and tried looking at the code to modify it, have been able to change it a very little bit, apart from figuring out that I need to rename my sheet exactly as Sheet1, and Not Sheet 1.

Here is the code, think I have gone wrong somewhere, as it is now copying the wrong data. I have attached the file with this code to show what's going wrong. Appreciate if you can help somehow.

[VBA]
Option Explicit
Sub Allocate()
Dim Cel As Range, Co As Range, i As Long, j As Long, k As Long
Dim Tot As Long
Dim Dic, a, FirstAddress As String, c As Range
Set Co = Range([A2], [A2].End(xlDown))
Set Dic = CreateObject("Scripting.Dictionary")
For Each Cel In Co
On Error Resume Next
Dic.Add Cel.Text, Cel
Next
Tot = 0
a = Dic.keys
j = 2
For i = 0 To Dic.Count - 1
j = j + 1
Sheets("Sheet2").Cells(j, 1) = a(i)
FirstAddress = ""
With Sheets("Sheet1").Columns("A")
Set c = .Find(a(i), LookIn:=xlValues)
If Not c Is Nothing Then
FirstAddress = c.Address
k = -1
Do
k = k + 1
If k > Tot Then Tot = k
c.Range("K1:T1").Copy Sheets("Sheet2").Cells(j, 2 + 5 * k)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
Next
'Set titles
Sheets("Sheet1").Range("A1:T1").Copy Sheets("Sheet2").[A2]
Sheets("Sheet2").Activate
Sheets("Sheet2").Range("K2:T2").AutoFill _
Destination:=Range(Cells(2, 2), Cells(2, 6 + 5 * Tot)), Type:=xlFillDefault
'Set numbering
Range("K1").Select
ActiveCell.FormulaR1C1 = "Set 1"
With Range("K1:T1")
.MergeCells = True
.Interior.ColorIndex = 6
.AutoFill Destination:=Range(Cells(1, 2), Cells(1, 6 + 5 * Tot)), Type:=xlFillDefault
End With
End Sub
[/VBA]