Sub Экспорт()
Dim wb As Workbook, arr(), DataArr, i As Long, j As Long, item As Long, cnt As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("На печать")
DataArr = Application.Transpose(.Cells(1, 1).CurrentRegion)
i = 1: cnt = 1
item = Application.Match(0, .Columns(2), 0)
Do
    For j = 1 To UBound(DataArr, 1)
        ReDim Preserve arr(1 To UBound(DataArr, 1), 1 To cnt)
        arr(j, cnt) = DataArr(j, i)
    Next j
    i = i + 1
    cnt = cnt + 1
Loop While i < item

    Set wb = Application.Workbooks.Add
    wb.Sheets(1).Cells(1, 1).Resize(UBound(arr, 2), UBound(arr, 1)) = Application.Transpose(arr)
    wb.SaveAs "C:\Печать этикеток\Этикетки на печать.xlsx"
    wb.Close True
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Sub Экспорт_2()
Dim wb As Workbook, item
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("На печать")
    item = Application.Match(0, .Columns(2), 0)
    Set wb = Application.Workbooks.Add
    .Range(.Cells(1, 1), .Cells(item - 1, 3)).Copy wb.Sheets(1).Cells(1, 1)
    wb.SaveAs "C:\Печать этикеток\Этикетки на печать.xlsx"
    wb.Close True
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Sub macro_1()
Dim Dict As Object, item, j, h, a
Dim arr, lstRow As Long
Set Dict = CreateObject("Scripting.Dictionary")
With Dict
    .CompareMode = vbTextCompare
End With
arr = Application.Transpose(Application.InputBox("Выберите диапазон для преобразования", Type:=8))

    For j = LBound(arr, 2) To UBound(arr, 2)
        If Not Dict.exists(arr(2, j)) Then
            Dict.Add arr(2, j), arr(3, j) & ";" & arr(1, j) & ";" & arr(4, j)
        Else
            Dict.item(arr(2, j)) = _
                Dict.item(arr(2, j)) & "|" & arr(3, j) & ";" & arr(1, j) & ";" & arr(4, j)
        End If
    Next j
With Sheets("Лист2") ' Лист2 поменять на нужное имя листа
    lstRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    For Each h In Dict.keys
        item = Split(Dict.item(h), "|")
        .Cells(lstRow, 1).Resize(UBound(item) + 1, 1) = h
        For Each a In item
            a = Split(a, ";")
            .Cells(lstRow, 2).Resize(1, UBound(a) + 1) = a
            lstRow = lstRow + 1
        Next a
    Next h
End With
End Sub

wb.Sheets(1).Columns.AutoFit ' вот эту строку

Sub Экспорт_2()
Dim wb As Workbook, item
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("На печать")
    item = Application.Match(0, .Columns(2), 0)
    Set wb = Application.Workbooks.Add
    .Range(.Cells(1, 1), .Cells(item - 1, 3)).Copy wb.Sheets(1).Cells(1, 1)
    wb.Sheets(1).Columns.AutoFit ' вот эту строку
    wb.SaveAs "C:\Печать этикеток\Этикетки на печать.xlsx"
    wb.Close True
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

MsgBox "Выполнено"
End Sub