Sub поиск_Z()
   Dim kl, rw, ns, i
   Range("A1").Select
   Cells.Find(What:="Z*", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
   xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
   , SearchFormat:=False).Activate
   kl = Selection.Column
   rw = Selection.Row
   ns = 9
   For i = kl To kl + 17 Step 2
       Sheets("Лист5").Cells(ns, 2) = Cells(rw, i)
       Sheets("Лист5").Cells(ns, 6) = Cells(rw + 2, i)
       Sheets("Лист5").Cells(ns, 7) = Cells(rw + 2, i + 1)
       ns = ns + 1
   Next
  Sheets("Лист5").Select
End Sub

Sub ertert()
Dim r As Range, adr$, x, y(), i&, j&, k&
With Sheets("Имя1").Columns(2)
     Set r = .Find("ККК", LookIn:=xlValues, LookAt:=xlWhole)
     If Not r Is Nothing Then
         adr = r.Address
         Do
             x = r.CurrentRegion.Value
             ReDim y(1 To UBound(x, 1) * UBound(x, 2), 1 To 11)
             For i = 3 To UBound(x)
                 If x(i, 1) = "ИИИ" Then Exit For
                 For j = 4 To UBound(x, 2) Step 2
                     If Len(x(i, j)) Then
                         k = k + 1
                         y(k, 1) = k
                         y(k, 2) = x(i, 2)
                         y(k, 6) = x(i, j)
                         y(k, 8) = x(1, j - 1)
                     End If
                 Next j
             Next i
             Sheets("Лист5").Cells(Rows.Count, 1).End(xlUp)(3, 1).Resize(k, 11).Value = y()
             k = 0
             Set r = .FindNext(r)
         Loop While r.Address <> adr
     End If
End With
End Sub