Additional mail merge items dependent on value

[aidan_cov]

I have a list including two columns which I use to mail merge in Word to print labels. One column contains names the other numerical values. Is it possible to tell the mail merge to print each label the number of times equivalent to the numerical value against that name? For example two cells may state "John" and "4" so I want 4 labels containing the words "John 4" before moving on to the next item on the mail merge lust. Thanks in advance.

 

[Macropod]

The following macro can be used to duplicate the worksheet and replicate as many rows as are needed there for each label. With this macro, the user can specify: the sheet name for the current data; the sheet name to be used as the mailmerge datasource; and the column # containing the labels, via the Data_Sheet, MergeSheet and LblCol parameters, respectively.

With this approach, you'd do the normal setup for the mailmerge main document, then run the macro below before doing the mailmerge. Because this approach uses a different worksheet than the data sheet for the actual merge, it requires you to create that worksheet, with all the column headings, before you specify the mailmerge data source. You can delete that sheet after doing the mailmerge main document setup.

Sub MultiLabelMergeSetup()
Application.ScreenUpdating = False
Dim xlWkShtSrc As Worksheet, xlWkShtTgt As Worksheet
Dim i As Long, j As Long, k As Long, l As Long
Dim lRow As Long, lCol As Long, LblCol As Long
Const Data_Sheet As String = "Sheet1"
Const MergeSheet As String = "Sheet2"
With ActiveWorkbook
  Set xlWkShtSrc = .Sheets(Data_Sheet)
  If SheetExists(ActiveWorkbook, MergeSheet) = True Then
    Set xlWkShtTgt = .Sheets(MergeSheet)
    xlWkShtTgt.UsedRange.Clear
  Else
    Set xlWkShtTgt = .Worksheets.Add(After:=xlWkShtSrc)
    xlWkShtTgt.Name = MergeSheet
  End If
  xlWkShtSrc.UsedRange.Copy
  xlWkShtTgt.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
    Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  With xlWkShtTgt.UsedRange
    .WrapText = False
    .Columns.AutoFit
    lRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
    lCol = .Cells.SpecialCells(xlCellTypeLastCell).Column
    LblCol = lCol ' If the label #s  aren't in the last column, specify the column index # here
    For i = lRow To 2 Step -1
      j = .Cells(i, lCol).Value: l = j
      If j > 1 Then
        .Range(.Cells(i, 1), .Cells(i, lCol)).Copy
        .Range(.Cells(i, 1), .Cells(i + j - 2, lCol)).Insert Shift:=xlShiftDown
        For k = i + j - 1 To i Step -1
          .Cells(k, LblCol).Value = l
          l = l - 1
        Next
      End If
    Next
  End With
End With
Set xlWkShtSrc = Nothing: Set xlWkShtTgt = Nothing
Application.ScreenUpdating = True
End Sub

Function SheetExists(xlWkBk As Workbook, xlWkShtNm As String) As Boolean
SheetExists = False
On Error GoTo NoSuchSheet
If Len(xlWkBk.Sheets(xlWkShtNm).Name) > 0 Then SheetExists = True
NoSuchSheet:
End Function

There is another way of achieving the same end without modifying the Excel workbook, but that requires some complicated field coding in Word and still requires a Word macro to drive the process.

 

[aidan_cov]

Dear Paul,
Thank you so much for that. I can't say that I understand it all but will give it a go when I get back to work and see how I get on. I am always amazed at the skills of everyone on here.
Thanks again