Private Sub Worksheet_Change(ByVal Target As Range)
Dim iTbl As ListObject
Set iTbl = Me.ListObjects(1)
If Not Intersect(Target, iTbl.ListColumns(1).DataBodyRange) Is Nothing Then
  Dim iSh As Worksheet
  Dim arr()
  arr = iTbl.ListColumns(1).DataBodyRange
  For Each iSh In ThisWorkbook.Worksheets
    If iSh.Name <> Me.Name Then
      iSh.ListObjects(1).ListColumns(1).DataBodyRange.Resize(iTbl.ListColumns(1).DataBodyRange.Rows.Count, 1) = arr
    End If
  Next
End If
End Sub

Sub MissingNumber()
Dim arr(), arrMissing()
Dim I&, N&, iTemp, iKey
With Worksheets("Лист1")
  arr = .Range("E2:E" & .Cells(.Rows.Count, "E").End(xlUp).Row).Value
End With
With CreateObject("Scripting.Dictionary")
  For Each iKey In arr
    iTemp = .Item(iKey)
  Next
  ReDim arrMissing(1 To arr(UBound(arr, 1), 1), 1 To 1)
  For I = 1 To arr(UBound(arr, 1), 1)
    If Not .Exists(I) Then
      N = N + 1
      arrMissing(N, 1) = Format(I, "00#")
    End If
  Next
End With
With Worksheets("Лист1")
  .Columns("G").NumberFormat = "@"
  .Range("G2").Resize(N, 1) = arrMissing
End With
End Sub

Sub Добавление_строки()

Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Расчет")
Dim le As Long
lr = Sheets("Расчет").Range("U" & Rows.Count).End(xlUp).Row
l = lr + 1


'''''''''''''''Дабавляем значения на лист'''''''''''''''''''
Rows(l).EntireRow.Insert 'добавление строки
Rows(l).RowHeight = 103.5 'задаем высоту строки


'''''''''''''''Копируем способ монтажа и вставляем в последнюю строку'''''''''''''''''''
Range("T19:U19").Select
Selection.Copy
Range("T" & l).Select
ActiveSheet.Paste

      
      '''''''''''''''копируем рисунок и вставляем в последнюю строку'''''''''''''''''''
Sheets("База").Select
ActiveSheet.Shapes.Range(Array("Рисунок 0")).Select
Selection.Copy
Sheets("Расчет").Select
Range("V" & l).Select
ActiveSheet.Paste
Range("V" & l).Formula = "=ф" & l

End Sub