Sub CopyData()
Dim arr, i As Long, j, shName As String, lr As Long, lC As Long, sh As Worksheet

arr = Worksheets("Сводка").Cells(4, 2).CurrentRegion ' подразумевается, что левый верхний угол таблицы - это В4
For i = 3 To UBound(arr, 1) ' 3 - это строка Подготовка котлована (первые 2 - это шапка)

    shName = "см." & arr(i, 1) ' склеиваем строку см. с №п.п
    If Not SheetExists(shName) Then
        Set sh = Application.Worksheets.Add(after:=Worksheets(Worksheets.Count)): shName = "см." & Int(Right(shName, 1)) - 1
        With sh
            .Name = ("см." & Int(Right(shName, 1)) + 1): Worksheets(shName).Cells(4, 2).CurrentRegion.Copy sh.Cells(3, 2): shName = ("см." & Int(Right(shName, 1)) + 1)
            .Cells(3, 2).CurrentRegion.Columns.AutoFit
        End With
    End If
With Worksheets(shName)
    .[B3] = "Смета" & arr(i, 1): .[B4] = "Наименование работы"
    For j = 2 To UBound(arr, 2)
            If j = 2 Then
                .Cells(4, 2) = .Cells(4, 2).Value & ": """ & arr(i, j) & """" ' Cells(4,2) == [B4]
                With .Cells(4, 2) ' B4
                    .HorizontalAlignment = xlCenter ' выравнивание по горизонтали ячейки И4
                    .WrapText = True ' перенос текста == переносить текст
                End With
               lr = 5: lC = 3
            Else
                .Cells(lr, lC) = arr(i, j)
                lC = lC + 1 ' смещаемся на 1 столбец вправо
            End If
        Next j
End With
Next i
End Sub
Private Function SheetExists(shName As String) As Boolean
Dim sh As Worksheet
    For Each sh In Worksheets
        If sh.Name = shName Then SheetExists = True: Exit Function
    Next sh
SheetExists = False
End Function

Sub EstimateFill()
  Dim a, adr$, b, c&, cc&, m, r&, rc&, re, s$, ws1 As Worksheet
  Set re = CreateObject("VBScript.RegExp"): re.Pattern = "[A-Z]+:*[A-Z]*"
  With Worksheets(1)
    rc = .Cells(Rows.Count, 1).End(xlUp).Row: Set ws1 = .[a1].Parent
    cc = .Cells(Rows.Count, 3).End(xlUp).Row: a = .[a1].CurrentRegion
  End With
  For c = 3 To cc
  If c - 1 > Worksheets.Count Then Worksheets(2).Copy after:=Worksheets(Worksheets.Count)
  With Worksheets(c - 1)
    For r = 2 To rc
      Set m = re.Execute(a(r, 1))(0)
      If InStr(m, ":") Then adr = Replace(m, ":", c & ":") & c Else adr = m & c
      b = ws1.Range(adr)
      If InStr(adr, ":") Then
        .Range(a(r, 2)).Resize(UBound(b), UBound(b, 2)) = b
      Else
        .Range(a(r, 2)) = Replace(a(r, 1), m, b)
      End If
    Next
  End With
  Next
  MsgBox "Заполнено смет: " & cc - 2 & " шт.", , "Готово!"
End Sub