Sub sbor_produktov()
Dim arr_1()
Dim arr_2()
ReDim arr_1(0)
ReDim arr_2(0)
Set shS = Sheets("Страви")
Set shK = Sheets("КК")
'On Error Resume Next
    With shS
        r = 18
        shK.Range("B18:B38").ClearContents
        For x = 5 To 9
            Set rFind = .Range("A1:A1000").Find(what:=shK.Cells(x, 3), lookat:=xlWhole)
            If Not rFind Is Nothing Then
                For c = 2 To .Cells(rFind.Row, Columns.Count).End(xlToLeft).Column Step 2
                    arr_1(UBound(arr_1)) = .Cells(rFind.Row, c)
                    arr_2(UBound(arr_2)) = .Cells(rFind.Row, c + 1) * shK.Range("H5")
                    ReDim Preserve arr_1(UBound(arr_1) + 1)
                    ReDim Preserve arr_2(UBound(arr_2) + 1)
                Next c
            End If
            shK.Range(Cells(18, 3 * (x - 5) + 3), Cells(38, 3 * (x - 5) + 3)).ClearContents
            shK.Cells(r, 2).Resize(UBound(arr_1), 1).Value = Application.Transpose(arr_1)
            shK.Cells(r, 3 * (x - 5) + 3).Resize(UBound(arr_2), 1).Value = Application.Transpose(arr_2)
            r = r + UBound(arr_1)
            ReDim arr_1(0)
            ReDim arr_2(0)
        Next x
    End With
End Sub