Sub Макрос1()
Dim H&, W&, i&, j&, k&
Dim EH&(2, 2), EW&(2, 3)
Dim sh As Worksheet, sh1 As Worksheet
Dim Nabor$, w1$, h1$, NameResult$
Dim tabl$()
NameResult = "Рез"
Set sh = Worksheets("Данные")
EH(1, 1) = 600: EH(2, 1) = 1200
EH(1, 2) = 1201: EH(2, 2) = 2400

EW(1, 1) = 450: EW(2, 1) = 600
EW(1, 2) = 601: EW(2, 2) = 1200
EW(1, 3) = 1201: EW(2, 3) = 1600

W = sh.Cells(2, 2)
H = sh.Cells(3, 2)

If W < EW(1, 3) Then
   If W < EW(1, 2) Then
      If W < EW(1, 1) Then
         Call mssg("W", W)
         Exit Sub
      Else
         w1 = "0"
      End If
   Else
      w1 = "1"
   End If
Else
   If W > EW(2, 3) Then
      Call mssg("W", W)
      Exit Sub
   Else
      w1 = "2"
   End If
End If
If H < EH(1, 2) Then
   If H < EH(1, 1) Then
      Call mssg("H", H)
      Exit Sub
   Else
      h1 = "0"
   End If
Else
   If H > EH(2, 2) Then
      Call mssg("H", H)
      Exit Sub
   Else
      h1 = "1"
   End If
End If
Nabor = "Набор-" & w1 & h1
ReDim tabl(16, 10)
For i = 0 To 16
   For j = 1 To 7
      tabl(i, j) = sh.Cells(i + 3, j + 6)
   Next j
   For j = 8 To 10
      tabl(i, j) = sh.Cells(i + 3, j - 4)
   Next j
Next i
tabl(0, 8) = "Поз."
tabl(0, 9) = "Артикул"
tabl(0, 10) = "Наименование"
tabl(0, 7) = "руб./ед."
j = Worksheets.Count
For i = 1 To j
   If Worksheets(i).Name = NameResult Then
      k = k + 1
   End If
Next i
If k = 0 Then
   Sheets.Add(After:=Sheets(j)).Name = NameResult
Else
   Worksheets(NameResult).Cells.Clear
End If
Set sh1 = Worksheets(NameResult)
k = 0
For j = 1 To 6
   If tabl(0, j) = w1 & h1 Then
      Exit For
   End If
Next j
For i = 0 To 16
   If tabl(i, j) <> "—" Then
      k = k + 1
      sh1.Cells(1, 1) = "Комплектация для " + Nabor
      sh1.Cells(k + 1, 1) = tabl(i, 8)
      sh1.Cells(k + 1, 2) = tabl(i, 9)
      sh1.Cells(k + 1, 3) = tabl(i, 10)
      sh1.Cells(k + 1, 4) = tabl(i, j)
      sh1.Cells(k + 1, 5) = tabl(i, 7)
      If i <> 0 Then
         sh1.Cells(k + 1, 6).Formula = "=" & _
         sh1.Cells(k + 1, 4).Address & "*" & _
         sh1.Cells(k + 1, 5).Address & "*" & sh.Cells(6, 2)
      End If
   End If
Next i
sh1.Cells(2, 6) = "стоимость"
sh1.Cells(2, 4) = Nabor
sh1.Cells(k + 2, 6).Formula = "=Sum(F3:F" & (k + 1) & ")"
sh1.Cells(k + 2, 4).Formula = "=Sum(D3:D" & k + 1 & ")"
Set r = sh1.Cells(2, 1).Resize(k, 6)
r.Borders.Weight = xlThin
For i = 7 To 10
   r.Borders(i).Weight = xlMedium
Next i
End Sub
Function mssg(ByVal A As String, ByVal par As String)
   If A = "W" Then
      MsgBox ("Нет такого набора по ширине (" & par & ")")
   ElseIf A = "H" Then
      MsgBox ("Нет такого набора по высоте (" & par & ")")
   End If
End Function