Private Sub CommandButton1_Click()
Dim m As Integer
Dim x As Integer
Dim out As Integer
m = Cells(2, 1)
x = Cells(2, 2)
out = Cells(2, 3)
     
     For i = m To x Step -x
        If i > 0 Then
            i = i - out
            j = j + 1
        End If
        If I < 0 Then
            i = i + out
            Exit For
        End If
    Next i
 

Cells(2, 4) = j
Cells(2, 5) = j + 1
Cells(2, 6) = i

End Sub

Sub Вставка2()
Dim i&, r As Range, shp As Shape
    For i = 4 To 393
        Set r = Sheets(2).Cells.Find(Cells(i, 3).Value, LookAt:=xlWhole)
        For Each shp In Sheets(2).Shapes
            If shp.TopLeftCell.Address = r.Next.Address Then
                shp.Copy
                Cells(i, 2).PasteSpecial xlPasteAll
            End If
        Next
    Next
Dim sh As Shape, ph#, pw, ch#, cw#, px#, py#
      For Each sh In ActiveSheet.Shapes
    If sh.Type = msoDiagram Then sh.Select False
    ph = sh.Height: pw = sh.Width
    ch = sh.TopLeftCell.MergeArea.Height: cw = sh.TopLeftCell.MergeArea.Width
    px = sh.TopLeftCell.MergeArea.Left + (cw - pw) / 2
    py = sh.TopLeftCell.MergeArea.Top + (ch - ph) / 2
    sh.Left = px
    sh.Top = py
      Next
End Sub

Sub Копирование()
AllRecs = Application.WorksheetFunction.CountA(Sheets("1").Range("C:C")) ' Получение количества строк на листе 1 (подсчет значений в столбце B)
cAllRecs = Application.WorksheetFunction.CountA(Sheets("2").Range("B:B")) 'Аналогично для листа 2
For CurRec = 1 To AllRecs
For cRecs = 3 To cAllRecs
    If Sheets("1").Cells(CurRec, 3) = Sheets("2").Cells(cRecs, 2) Then 'сверка критериев если Они равны то:
    'в этой строке указанным ячейкам присвоить значения из листа 1
    Sheets("1").Cells(cRecs, 6) = Sheets("2").Cells(CurRec, 3)
    Sheets("1").Cells(cRecs, 7) = Sheets("2").Cells(CurRec, 4)
    End If 'конец условия
Next cRecs 'следующая строка на Листе2
'После  окончания проверки на Листе 2 возвращаемся на Лист 1 за следующей суммой критериев:
Next CurRec
End Sub