Sub invent()
Dim otv As String, poz As Range
Dim x, y(), c(), p(), a(), i As Long, j As Byte, k As Long
Application.ScreenUpdating = False

x = Range("B2:v" & Cells(Rows.Count, 2).End(xlUp).Row).Value
otv = Application.InputBox("Введите город", "111", "Россия")

ReDim y(1 To UBound(x) * 2, 1 To 6)
ReDim с(1 To UBound(x) * 2, 1 To 6)
ReDim p(1 To UBound(x) * 2, 1 To 6)
ReDim a(1 To UBound(x) * 2, 1 To 6)
For i = 1 To UBound(x)
    j = j + 1: If j = 6 Then j = 1: k = k + 1
    y(1 + 6 * k, j) = "Наименование:"
    y(2 + 6 * k, j) = "номер:"
    y(3 + 6 * k, j) = "ко-во:"
    y(4 + 6 * k, j) = "тип:"
    y(5 + 6 * k, j) = "цена1:"
    y(6 + 6 * k, j) = "цена2:"
    
    с(1 + 6 * k, j) = x(i, 4)
    с(2 + 6 * k, j) = x(i, 7)
    с(3 + 6 * k, j) = x(i, 10)
    с(4 + 6 * k, j) = x(i, 16)
    с(5 + 6 * k, j) = x(i, 20)
    с(6 + 6 * k, j) = x(i, 21)
    p(1 + 6 * k, j) = x(i, 2)
    a(1 + 6 * k, j) = x(i, 5)
    
Next i

With Sheets("Бирки")
    .Cells.EntireRow.Hidden = False: .Cells.ClearContents
    .Cells(1, 1).Resize(6 * (k + 1), 1).Value = y
    .Cells(1, 2).Resize(6 * (k + 1), 1).Value = с
    .Cells(1, 3).Resize(6 * (k + 1), 1).Value = p
    .Cells(1, 4).Resize(6 * (k + 1), 1).Value = a
    For Each poz In .Cells(1, 1).Resize(6 * (k + 1))
        If Len(poz) = 0 Then
            Range(poz, poz.Offset(-1)).EntireRow.Hidden = True
        End If
    Next poz
End With

Application.ScreenUpdating = True
End Sub