Sub u_6()
    'отключаем обновление экрана
    Application.ScreenUpdating = False
    'сотрем старые данные.....................................
    'нижняя, заполненная ячейка столбца A листа 4
    a = Sheets("4").Cells(Rows.Count, "a").End(xlUp).Row
    If a > 1 Then Sheets("4").Range("a2:d" & a).Clear
    'запишем новые данные.....................................
    'нижняя, заполненная ячейка столбца A листа 1
    b = Sheets("1").Cells(Rows.Count, "a").End(xlUp).Row
    If b > 1 Then
        'пройдемся циклом по строка листа 1
        For c = 2 To b 'со 2-й по нижнюю
            'правый столбец проверяемой строки
            d = Sheets("1").Cells(c, Columns.Count).End(xlToLeft).Column
            If d > 1 Then
                e = d - 1 'кол-во номеров в строке
                f = Sheets("4").Cells(Rows.Count, "a").End(xlUp).Row + 1 'очередная строка вставки
                g = f + e - 1
                h = Sheets("1").Range("a" & c).Value 'животное Лист 1
                Sheets("4").Range("a" & f & ":a" & g) = h 'запишем животное на лист 4
                'запищем номера
                Sheets("1").Range(Sheets("1").Cells(c, 2), Sheets("1").Cells(c, d)).Copy
                Sheets("4").Range("b" & f).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=True
                'очистим буфер обмена
                Application.CutCopyMode = False
                'характеристи
                i = Application.Match(h, Sheets("2").Range("c:c"), 0) 'верхняя строка животного
                j = Application.CountIf(Sheets("2").Range("c:c"), h)
                k = i + j - 1 'нижняя строка животного
                'пройдемся по номерам, найдем характеристики
                For Each l In Sheets("4").Range("b" & f & ":b" & g)
                    m = l.Value 'номер
                    'Application.VLookup = формула* ВПР
                    'характеристики
                    l.Offset(0, 1) = Application.VLookup(m, Sheets("2").Range("a" & i & ":b" & k), 2, 0)
                    'кол-во лист 2
                    n = Application.VLookup(m, Sheets("2").Range("a" & i & ":d" & k), 4, 0)
                    'кол-во лист 3
                    o = Application.VLookup(h, Sheets("3").Range("a:b"), 2, 0)
                    l.Offset(0, 2) = n / o
                Next
            End If
        Next
    End If
    'включаем обновление экрана
    Application.ScreenUpdating = True
End Sub