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