Row merging based column values

[Hansie]

Hi all


I need a macro that can merge rows of data based on common values in certain columns. This is to allow a mailmerge email to be sent with details from multiple rows in a single mail.


Review the document at link below to view the source and target sheet. https://docs.google.com/spreadsheet/pub?key=0AkpHbr-mpDiAdEpKVjREbUp6ZG9Vel9RYnJwWkNQY2c&output=xls


Thank you

J

 

[SirJB7]

Hi, Hansie!


First of all welcome to Chandoo's website Excel forums. Thank you for your joining us and glad to have you here.


As a starting point I'd recommend you to read the green sticky topics at this forums main page. There you'll find general guidelines about how this site and community operates (introducing yourself, posting files, netiquette rules, and so on).


Among them you're prompted to perform searches within this site before posting, because maybe your question had been answered yet.


Feel free to play with different keywords so as to be led thru a wide variety of articles and posts, and if you don't find anything that solves your problem or guides you towards a solution, you'll always be welcome back here. Tell us what you've done, consider uploading a sample file as recommended, and somebody surely will read your post and help you.


And about your question...


If you haven't performed yet the search herein, try going to the topmost right zone of this page (Custom Search), type the keywords used in Tags field when creating the topic or other proper words and press Search button. You'd retrieve many links from this website, like the following one(s) -if any posted below-, maybe you find useful information and even the solution. If not please advise so as people who read it could get back to you as soon as possible.


As questions about mailing have been widely posted, so are the answers. I remember one I wrote a few days ago, check this link:

http://chandoo.org/forums/topic/help-on-vba-scripting-1


There you have all the components to perform mail creation, so regarding your question of merging rows I'd recommend you 2 alternatives:

a) Separate both processes, that's to say, create merged data in another worksheet.

b) Loop row wise (in the linked file it's done column wise) and unify all data for a person in one only mail.


Regards!

 

[Hansie]

Hi SirJB7


Thanks for the welcome and I will most certainly go through the startup posts.

I have been searching for the last 2 days and have not found a suitable response. The 1 you have pointed me to unfortunately does not help though it is a impressive solution and might be useful for such a case.


Inspired by this blog,and what can be achieved, I will be using this earlier in my quest to automate and improve processes as well as share my experience as I grow along.


I have reviewed the link, however cannot see how this would be applicable to this case. I have done extensive searches with no luck. this could be due to my novice level.


I agree with your approach 1 and this is what I am aiming for as I will use this new worksheet as the data source for a word mail merge.


I look forward to your assistance.


Thank you

J

 

[SirJB7]

Hi, Hansie!


Give a look at this file:

https://dl.dropboxusercontent.com/u/60558749/Row%20merging%20based%20column%20values%20-%20MailMerger%20%28for%20Hansie%20at%20chandoo.org%29.xlsm

This is the code for the command buttons:

-----

Option Explicit

' constants
Const gksWSSource = "Source"
Const gksSource = "SourceTable"
Const gksWSTarget = "Target"
Const gksTarget = "TargetTable"

' declarations
Dim grngS As Range, grngT As Range

Sub MergeByCriteria()
' constants
' declarations
Dim sCustomerX As String, sACCMainX As String, sAccMailX As String, sDocNOX As Long
Dim sOrderX As String, sONameX As String, sHoursX As String
Dim bChange As Boolean
Dim I As Long, J As Long
' start
Set grngS = Worksheets(gksWSSource).Range(gksSource)
Set grngT = Worksheets(gksWSTarget).Range(gksTarget)
With grngT
If .Rows.Count > 1 Then Range(.Rows(2), .Rows(.Rows.Count)).ClearContents
End With
' process
With grngS
I = 2
J = 1
Do Until I > .Rows.Count
' control values
sCustomerX = .Cells(I, 1).Value
sACCMainX = .Cells(I, 2).Value
sAccMailX = .Cells(I, 3).Value
sDocNOX = .Cells(I, 4).Value
bChange = False
' totals
sOrderX = ""
sONameX = ""
sHoursX = ""
Do Until I > .Rows.Count Or bChange
' accumulate
If Len(sOrderX) > 0 Then
sOrderX = sOrderX & vbCrLf
sONameX = sONameX & vbCrLf
sHoursX = sHoursX & vbCrLf
End If
sOrderX = sOrderX & .Cells(I, 5).Value
sONameX = sONameX & .Cells(I, 6).Value
sHoursX = sHoursX & .Cells(I, 8).Value
' control
I = I + 1
bChange = (sCustomerX <> .Cells(I, 1).Value) Or _
(sACCMainX <> .Cells(I, 2).Value) Or _
(sAccMailX <> .Cells(I, 3).Value)
Loop
' subtotal
J = J + 1
grngT.Cells(J, 1).Value = sCustomerX
grngT.Cells(J, 2).Value = sACCMainX
grngT.Cells(J, 3).Value = sAccMailX
grngT.Cells(J, 4).Value = sDocNOX
grngT.Cells(J, 5).Value = sOrderX
grngT.Cells(J, 6).Value = sONameX
grngT.Cells(J, 7).Value = sHoursX
Loop
End With
' end
With Worksheets(gksWSTarget)
.Activate
.Range("A2&#34.Select
End With
Set grngT = Nothing
Set grngS = Nothing
Beep
End Sub

Sub MailStuff(pbSend As Boolean)
' constants
Const ksWS = "Target"
Const ksData = "TargetTable"
Const ksSeparator = " - "
Const ksSubject = "Mail subject"
Const ksText1 = "Dear sir/madame:"
Const ksText2 = "Regarding this reference:"
Const ksText3 = "This is the related information (Order, Order name, Hours):"
Const ksText4 = "Signed by XXX."
' declarations
Dim rng As Range
Dim olApp As Object, olMail As Object
Dim sMail As String, sText As String
Dim I As Integer, J As Integer
Dim K1 As Integer, K2 As Integer, K3 As Integer, L As Integer
Dim A1 As String, A2 As String, A3 As String, A As String, bOk As Boolean
' start
Set rng = Worksheets(ksWS).Range(ksData)
Set olApp = CreateObject("Outlook.Application&#34
' process
With rng
For I = 2 To .Rows.Count
' create mail
Set olMail = olApp.CreateItem(0)
sMail = .Cells(I, 3).Value
' split & order text chunks
A1 = .Cells(I, 5).Value & vbCrLf
A2 = .Cells(I, 6).Value & vbCrLf
A3 = .Cells(I, 7).Value & vbCrLf
A = ""
K1 = 1
K2 = 1
K3 = 1
For J = 1 To (Len(A1) - Len(Replace(A1, vbCrLf, "&#34)) / Len(vbCrLf)
L = InStr(K1, A1, vbCrLf)
A = A & Mid$(A1, K1, L - K1) & ksSeparator
K1 = L + Len(vbCrLf)
L = InStr(K2, A2, vbCrLf)
A = A & Mid$(A2, K2, L - K2) & ksSeparator
K2 = L + Len(vbCrLf)
L = InStr(K3, A3, vbCrLf)
A = A & Mid$(A3, K3, L - K3) & vbCrLf
K3 = L + Len(vbCrLf)
Next J
' build body
sText = ksText1 & vbCrLf & sMail & vbCrLf & vbCrLf & _
ksText2 & vbCrLf & _
.Cells(I, 1).Value & vbCrLf & _
.Cells(I, 2).Value & vbCrLf & _
.Cells(I, 4).Value & vbCrLf & _
vbCrLf & vbCrLf & _
ksText3 & vbCrLf & A & _
vbCrLf & vbCrLf & _
ksText4
' view/send mail
'=====
'This block of code written by Ron de Bruin, copied from
'http://msdn.microsoft.com/en-us/library/ff458119(office.11).aspx#odc_office_UseExcelObjectModeltoSendMail_Introduction
On Error Resume Next
' Change the body and subject in the macro before you run it.
With olMail
.To = sMail
.CC = ""
.BCC = ""
.Subject = ksSubject
.Body = sText
'You're not sending an attachment, so I commented this out
'.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:test.txt&#34
' In place of the following statement, you can use ".Display" to
' display the mail.
If pbSend Then .Send Else .Display
DoEvents
End With
On Error GoTo 0
'=======
' destroy mail
Set olMail = Nothing
Next I
End With
' end
Set olApp = Nothing
Beep
End Sub

-----


Just advise if any issue.


Regards!