Function СТОЛБЦЫ(iRng As Range, iCrit)
Dim arr(), clmnsArr() As String
Dim lRow&, I&, J&, N&, maxN&
Dim clrRange As Range
On Error GoTo ErrHndl
Set clrRange = Application.Caller
With clrRange.Parent
  lRow = .Cells(.Rows.Count, iRng.Column).End(xlUp).Row
End With
arr = iRng.Resize(lRow).Value
ReDim clmnsArr(1 To UBound(arr, 1), 1 To 1)
For I = LBound(arr, 1) To UBound(arr, 1)
  N = N + 1
  If maxN < N Then maxN = N
  clmnsArr(N, UBound(clmnsArr, 2)) = CStr(arr(I, 1))
  If arr(I, 1) = iCrit Then
    ReDim Preserve clmnsArr(1 To UBound(clmnsArr, 1), 1 To UBound(clmnsArr, 2) + 1)
    N = 0
  End If
Next
arr = Application.Transpose(clmnsArr)
ReDim Preserve arr(1 To UBound(arr, 1), 1 To maxN)
СТОЛБЦЫ = Application.Transpose(arr)
Exit Function
ErrHndl:
  СТОЛБЦЫ = CVErr(xlErrNA)
End Function

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Dim r As Long
  Dim iCl As Range
  On Error Resume Next
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Cancel = True
  r = Target.Row + 1
  Rows(r).Insert Shift:=xlDown
  Target.EntireRow.Copy
  Cells(r, 1).PasteSpecial Paste:=xlPasteFormulas
  For Each iCl In Range(Cells(r, 3), Cells(r, Cells(r, Columns.Count).End(xlToLeft).Column)).Cells
    If Not iCl.HasFormula Then iCl.ClearContents
  Next
  Cells(r, 1).Select
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub

Option Compare Text

Sub Foundation()
Dim arr(), fndArr(), tmpArr, keyArr
Dim dic As Object
Dim I&, J&, N&, iTmp, iKey
Dim iClmn&
On Error Resume Next
Application.ScreenUpdating = False
With Worksheets("Основная таблица")
  arr = .Range("A2:C" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
End With
Set dic = CreateObject("Scripting.Dictionary")
For I = LBound(arr, 1) To UBound(arr, 1)
  Select Case True
    Case arr(I, 3) Like "Армир*"
      iClmn = 4
    Case arr(I, 3) Like "Опалуб*"
      iClmn = 5
    Case arr(I, 3) Like "Заклад*"
      iClmn = 6
    Case arr(I, 3) Like "Засып*"
      iClmn = 11
    Case arr(I, 3) Like "Бетон*"
      iClmn = 8
    Case arr(I, 3) Like "Гидро*"
      If arr(I, 2) Like "*праймер*" Then
        iClmn = 9
      Else
        iClmn = 10
      End If
  End Select
  iTmp = Replace(Replace(Replace(Replace(arr(I, 2), ",", vbCrLf), ";", vbCrLf), Chr(13), vbCrLf), ":", vbCrLf)
  tmpArr = Split(iTmp, vbCrLf)
  For J = LBound(tmpArr) To UBound(tmpArr)
    iKey = RegExpExtract(tmpArr(J), "[КП]м\d+")
    If Not IsError(iKey) Then
      If Not dic.Exists(iKey) Then
        ReDim keyArr(1 To 11, 1 To 1)
        keyArr(1, 1) = iKey
        keyArr(iClmn, 1) = arr(I, 1)
        dic.Add iKey, keyArr
      Else
        keyArr = dic(iKey)
        If IsEmpty(keyArr(iClmn, 1)) Then
          keyArr(iClmn, 1) = arr(I, 1)
        Else
          keyArr(iClmn, 1) = keyArr(iClmn, 1) & vbCrLf & arr(I, 1)
        End If
        dic(iKey) = keyArr
      End If
    End If
  Next
Next
ReDim fndArr(1 To 10000, 1 To 11)
For Each iKey In dic.Keys
  N = N + 1
  keyArr = dic(iKey)
  For J = LBound(keyArr, 1) To UBound(keyArr, 1)
    fndArr(N, J) = keyArr(J, 1)
  Next
Next
Worksheets("Лист1").Range("A2").Resize(N, 11) = fndArr
Worksheets("Лист1").Activate
Application.ScreenUpdating = True
MsgBox "Done!", vbInformation + vbOKOnly
End Sub

Function RegExpExtract(ByVal Text As String, Pattern As String, Optional Item As Integer = 1)
    On Error GoTo ErrHandl
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = Pattern
    regex.Global = True
    If regex.Test(Text) Then
        Set matches = regex.Execute(Text)
        RegExpExtract = matches.Item(Item - 1)
        Exit Function
    End If
ErrHandl:
    RegExpExtract = CVErr(xlErrValue)
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, Range("O3")) Is Nothing Then
  If Target.Count = 1 Then
    If Target.Validation.Type = 3 Then 'проверка на наличие вып.списка (нужна ли?)
      Dim arr()
      Dim rngDest As Range
      Dim I&, lClmn&
      arr = Me.ListObjects("Таблица1").DataBodyRange.Value
      For I = LBound(arr, 1) To UBound(arr, 1)
        If Target = arr(I, 3) Then
          Application.ScreenUpdating = False
          Application.EnableEvents = False
          lClmn = Cells(Target.Row, Columns.Count).End(xlToLeft).Column
          lClmn = IIf(lClmn < 17, 17, lClmn + 1)
          Cells(Target.Row, lClmn) = arr(I, 8)
          Target.Offset(, 1) = Target.Offset(, 1) + 1
        End If
      Next
    End If
  End If
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C2")) Is Nothing Then
  If Target.Count = 1 Then
    If Target = "----" Then
      On Error Resume Next
      Application.EnableEvents = False
      Range("C6") = "----"
      Application.EnableEvents = True
    End If
  End If
End If
End Sub

Sub UNIQUE_PLUS1()
Dim arr()
Dim I&, iKey
Dim dic As Object
With Worksheets("как есть")
  arr = .Range("A1:B" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With
Set dic = CreateObject("Scripting.Dictionary")
With dic
  For I = LBound(arr, 1) To UBound(arr, 1)
    If Not .Exists(arr(I, 1)) Then
      .Add arr(I, 1), arr(I, 2)
    Else
      .Item(arr(I, 1)) = .Item(arr(I, 1)) + arr(I, 2)
    End If
  Next
End With
I = 0
With dic
  ReDim arr(1 To .Count, 1 To 2)
  For Each iKey In .Keys
    I = I + 1
    arr(I, 1) = iKey
    arr(I, 2) = .Item(iKey)
  Next
End With
With Worksheets("как есть")
  .Range("G1").Resize(dic.Count, 2) = arr
End With
End Sub