If the mailmerge data source has a field that indicates how many labels are required for each record, and the datasource is an Excel workbook the user is allowed to modify, 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 afterwards, if you want.
Code:
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(SheetName As String) As Boolean
Dim i As Long: SheetExists = False
For i = 1 To Sheets.Count
If Sheets(i).Name = SheetName Then
SheetExists = True: Exit For
End If
Next
End Function