Running VBA macro after a mail merge

[lincschris]

I am performing a mail merge from our corporate Admin system which is exporting 2 levels of data, the second the child records of the first. To enable this to work I have exported the child level data as concatenated merge fields with a return character between rows. These merge fields are put in a single row table. My macro then interrogates each cell and if the data in the merge field contains a return character a new row is added to the table and the data is split and so on.

My problem is that this works fine if there is one or two parent records, but any more than that it seems to ignore from the merge however, if I comment out my code the merge works correctly.

I suspect that the event that I am using to run the macro is incorrect - I'm using Document_Open. Does anyone have any clues?

 

[PHV]

if I comment out my code
Which code ?

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[lincschris]

The VBA macro code

 

[SkipVought]

The VBA macro code

How helpful! It still is unenlightening!

Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]

 

[lincschris]

The code is as follows:

In the Word Document

Option Explicit

Dim MergeApp As New QubeClass

Sub Document_Open()
Set MergeApp.MailMergeApp = Word.Application
End Sub

In my ClassModule

Public WithEvents MailMergeApp As Word.Application
Public intTableCount As Integer
Public intTableMax As Integer

Private Const intStartUnitsTable As Integer = 1
Private Const intStartUnitsRow As Integer = 2
Private Const intExtraUnitsRow As Integer = 1
Private Const intStartDiaryTable As Integer = 2
Private Const intStartDiaryRow As Integer = 2
Private Const intExtraDiaryRow As Integer = 0
Private Const intStartVoidsTable As Integer = 3
Private Const intStartVoidsRow As Integer = 2
Private Const intExtraVoidsRow As Integer = 1
Private Const intNumberTables As Integer = 5

Option Explicit

Private Sub MailMergeApp_MailMergeAfterRecordMerge(ByVal doc As Document)

On Error GoTo Err_Handler

intTableMax = ActiveDocument.Tables.Count

' Sort out the units tables
intTableCount = intStartUnitsTable
While intTableCount <= intTableMax
Call SubSplitCells(intStartUnitsRow, intExtraUnitsRow)
intTableCount = intTableCount + intNumberTables
Wend

' Sort out the diary tables
intTableCount = intStartDiaryTable
While intTableCount <= intTableMax
Call SubSplitCells(intStartDiaryRow, intExtraDiaryRow)
intTableCount = intTableCount + intNumberTables
Wend

' Sort out the voids tables
intTableCount = intStartVoidsTable
While intTableCount <= intTableMax
Call SubSplitCells(intStartVoidsRow, intExtraVoidsRow)
intTableCount = intTableCount + intNumberTables
Wend

Exit_Here:
Selection.HomeKey Unit:=wdStory
Exit Sub

Err_Handler:
Dim strError As String
Dim strHelp As String
Dim strContext As String
strError = "Error #" & Err.Number & vbCr & _
" " & Err.Description & vbCr & _
" (Source: " & Err.Source & ")" & vbCr
If Err.HelpFile = "" Then
strError = strError & _
" No Help file available" & _
vbCr & vbCr
MsgBox strError, vbMsgBoxHelpButton, "After Mail Merge Procedure"
Else
strHelp = Err.HelpFile
strContext = Err.HelpContext
strError = strError & _
" (HelpFile: " & strHelp & ")" & vbCr & _
" (HelpContext: " & strContext & ")" & _
vbCr & vbCr
MsgBox strError, vbMsgBoxHelpButton, "After Mail Merge Procedure", strHelp, strContext
End If
Resume Exit_Here

End Sub

Private Sub SubSplitCells(intStartRow As Integer, intExtraRow As Integer)
On Error GoTo Err_Handler
Dim objCell As Cell
Dim objObj As Object
Dim strString As String

For Each objCell In ActiveDocument.Tables(intTableCount).Rows(intStartRow).Cells
If Len(objCell.Range.Text) > 0 Then
Let strString = objCell.Range.Text
objCell.Range.Delete
Call DistributeText(strString, objCell.ColumnIndex, intStartRow, intExtraRow)
End If
Next objCell

Exit_Here:
Exit Sub

Err_Handler:
Dim strError As String
Dim strHelp As String
Dim strContext As String
strError = "Error #" & Err.Number & vbCr & _
" " & Err.Description & vbCr & _
" (Source: " & Err.Source & ")" & vbCr
If Err.HelpFile = "" Then
strError = strError & _
" No Help file available" & _
vbCr & vbCr
MsgBox strError, vbMsgBoxHelpButton, "Split Cells"
Else
strHelp = Err.HelpFile
strContext = Err.HelpContext
strError = strError & _
" (HelpFile: " & strHelp & ")" & vbCr & _
" (HelpContext: " & strContext & ")" & _
vbCr & vbCr
MsgBox strError, vbMsgBoxHelpButton, "Split Cells", strHelp, strContext
End If
Resume Exit_Here

End Sub

Private Sub DistributeText(strInput As String, targetColumn As Integer, intTargetRow As Integer, intExtraRow As Integer)
On Error GoTo Err_Handler
Dim startOfCurrentSection As Integer
Dim targetRow As Integer
Dim intCount As Integer

Let startOfCurrentSection = 1
Let targetRow = intTargetRow

For intCount = 1 To Len(strInput)
If Mid$(strInput, intCount, 1) = Chr(11) Then
Call PopulateCell(targetRow, targetColumn, startOfCurrentSection, intCount, strInput, intExtraRow)
Let startOfCurrentSection = intCount + 1
End If
Next intCount

If startOfCurrentSection < Len(strInput) Then
Call PopulateCell(targetRow, targetColumn, startOfCurrentSection, Len(strInput), strInput, intExtraRow)
End If

Exit_Here:
Exit Sub

Err_Handler:
Dim strError As String
Dim strHelp As String
Dim strContext As String
strError = "Error #" & Err.Number & vbCr & _
" " & Err.Description & vbCr & _
" (Source: " & Err.Source & ")" & vbCr
If Err.HelpFile = "" Then
strError = strError & _
" No Help file available" & _
vbCr & vbCr
MsgBox strError, vbMsgBoxHelpButton, "Distribute Text"
Else
strHelp = Err.HelpFile
strContext = Err.HelpContext
strError = strError & _
" (HelpFile: " & strHelp & ")" & vbCr & _
" (HelpContext: " & strContext & ")" & _
vbCr & vbCr
MsgBox strError, vbMsgBoxHelpButton, "Distribute Text", strHelp, strContext
End If
Resume Exit_Here

End Sub

Private Sub PopulateCell(targetRow As Integer, targetColumn As Integer, startPos As Integer, endPos As Integer, strInput As String, intExtraRow As Integer)
On Error GoTo Err_Handler
Dim cellRange As Range

If targetRow > ActiveDocument.Tables(intTableCount).Rows.Count - intExtraRow Then
' ActiveDocument.Tables(intTableCount).Rows.Add BeforeRow:=ActiveDocument.Tables(intTableCount).Rows(targetRow)
ActiveDocument.Tables(intTableCount).Rows(targetRow - 1).Select
Selection.InsertRowsBelow
End If

Set cellRange = ActiveDocument.Tables(intTableCount).Rows(targetRow).Cells(targetColumn).Range

cellRange.InsertAfter (Mid$(strInput, startPos, endPos - startPos))

Let targetRow = targetRow + 1

Exit_Here:
Exit Sub

Err_Handler:
Dim strError As String
Dim strHelp As String
Dim strContext As String
strError = "Error #" & Err.Number & vbCr & _
" " & Err.Description & vbCr & _
" (Source: " & Err.Source & ")" & vbCr
If Err.HelpFile = "" Then
strError = strError & _
" No Help file available" & _
vbCr & vbCr
MsgBox strError, vbMsgBoxHelpButton, "Populate Cells"
Else
strHelp = Err.HelpFile
strContext = Err.HelpContext
strError = strError & _
" (HelpFile: " & strHelp & ")" & vbCr & _
" (HelpContext: " & strContext & ")" & _
vbCr & vbCr
MsgBox strError, vbMsgBoxHelpButton, "Populate Cells", strHelp, strContext
End If
Resume Exit_Here

End Sub

' This procedure just loops for the number of seconds that is
' passed to it. It is used in code to simulate a wait period
Public Sub WaitForMe(iSeconds As Integer)
On Error GoTo Err_Handler

Dim vEndTime As Variant

vEndTime = DateAdd("s", iSeconds, Now())
Do While vEndTime > Now()
DoEvents
Loop

Exit_Here:
Exit Sub

Err_Handler:
Dim strError As String
Dim strHelp As String
Dim strContext As String
strError = "Error #" & Err.Number & vbCr & _
" " & Err.Description & vbCr & _
" (Source: " & Err.Source & ")" & vbCr
If Err.HelpFile = "" Then
strError = strError & _
" No Help file available" & _
vbCr & vbCr
MsgBox strError, vbMsgBoxHelpButton, "Procedure WaitForMe"
Else
strHelp = Err.HelpFile
strContext = Err.HelpContext
strError = strError & _
" (HelpFile: " & strHelp & ")" & vbCr & _
" (HelpContext: " & strContext & ")" & _
vbCr & vbCr
MsgBox strError, vbMsgBoxHelpButton, "Procedure WaitForMe", strHelp, strContext
End If
Resume Exit_Here

End Sub


I suspect that the problem is to do with the original Document_Open procedure as this seems to run after the first mail merge page has been populated, rather than after the last page.

Any suggestions?

Chris

 

[lincschris]

Wouldn't you believe it? As soon as I sent my last post I twigged that the answer was to not use

Private Sub MailMergeApp_MailMergeAfterRecordMerge(ByVal doc As Document)

but to use:

Private Sub MailMergeApp_MailMergeAfterMerge(ByVal doc As Document, ByVal DocResult As Document)

Obvious really!!!

Thanks anyway.

Chris