Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error Resume Next
Dim Product As Range, dataa As Range 'объявление переменных
If Not Intersect(Target, Range("i19,k19,m19,o19,q19,s19,u19,w19")) Is Nothing Then ' отслеживание двоеного нажатия на указанные ячейки
    Target.Offset(0, -1) = Target.Offset(0, -1) + 1 'если одна из указанных выше ячеек тогда прибавляем 1 к значению
    Set Product = Columns(27).Find(Target.Offset(-1, -1)) 'ищем продукт которому добавляли 
    Set dataa = Rows(15).Find(Date) 'ищем сегодняшнюю дату
    Cells(Product.Row, dataa.Column + 1) = Cells(Product.Row, dataa.Column + 1) + 1 'добавляем единичку под сегодняшней датой в столбец приход
    Cancel = True
End If
If Not Intersect(Target, Range("i20,k20,m20,o20,q20,s20,u20,w20")) Is Nothing Then ' отслеживание двоеного нажатия на указанные ячейки
    Target.Offset(-1, -1) = Target.Offset(-1, -1) - 1'если одна из указанных выше ячеек тогда прибавляем 1 к значению
    Set Product = Columns(27).Find(Target.Offset(-2, -1)) 'ищем продукт у которого отнимали
    Set dataa = Rows(15).Find(Date) 'ищем сегодняшнюю дату
    Cells(Product.Row, dataa.Column) = Cells(Product.Row, dataa.Column) - 1 'отнимаем единичку под сегодняшней датой в столбец расход
    Cancel = True
End If
End Sub

Sub mrshkei()
Dim i As Long, j As Long, arrIN, arrOUT, k As Long, x As Long
k = 1
arrIN = Range("A1:G4")
x = (UBound(arrIN) - 1) * (UBound(arrIN, 2) - LBound(arrIN, 2))
ReDim arrOUT(1 To x, 1 To 3)
For j = LBound(arrIN) + 1 To UBound(arrIN)
    For i = LBound(arrIN) + 1 To UBound(arrIN, 2) - LBound(arrIN, 2) + 1
        arrOUT(k, 1) = arrIN(j, 1)
        arrOUT(k, 2) = arrIN(1, i)
        arrOUT(k, 3) = arrIN(j, i)
    k = k + 1
    Next i
Next j
Range("A7").Resize(UBound(arrOUT), 3) = arrOUT
End Sub

Sub mrshkei()
a = Timer
Dim arr, i As Long, j As Long, col As New Collection
arr = Range("D2:AG99999")
For i = LBound(arr) To UBound(arr)
    For j = LBound(arr) To UBound(arr, 2) - LBound(arr, 2) + 1
        On Error Resume Next
        col.Add arr(i, j), CStr(arr(i, j))
    Next j
Next i
ReDim arr(1 To col.Count, 1 To 1)
For i = 1 To col.Count
    arr(i, 1) = col(i)
Next i
Range("AI2").Resize(UBound(arr), 1) = arr
Debug.Print Timer - a
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
   If Target.Cells.Count > 1 Then Exit Sub
   If Not Intersect(Target, [AW4]) Is Nothing Then
      Dim r As Range, c As Range
         Set r = Columns(1).Find([AW2])
         Set c = Rows(1).Find([AW3])
          Cells(r.Row, c.Column) = [AW4]
   End If
End Sub

Sub mrshkei()
Dim arr, i As Long, lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
    arr = Split(Cells(i, 1), ";")
    For n = LBound(arr) To UBound(arr)
        t = t & " " & n + 1 & ". " & arr(n)
    Next n
    Cells(i, 2) = t & ".": t = Empty
Next i
End Sub

Sub mrshkei()
Dim arr, i As Long, lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
    arr = Split(Cells(i, 1), ";")
    For n = LBound(arr) To UBound(arr)
    x = UBound(arr) + 1
        t = t & " " & n + 1 & ". " & arr(n)
    Next n
    Cells(i, 2) = t & "."
    t = Empty
Next i
End Sub

=ЕСЛИОШИБКА(ПРОСМОТР(2;1/ПОИСК($H$2:$H$6;B2);$I$2:$I$6);"")

Sub mrshkei()
Dim arr, i As Long, lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
    arr = Split(Cells(i, 1), ";")
    For n = LBound(arr) To UBound(arr)
    x = UBound(arr) + 1
        t = t & " " & n + 1 & ". " & arr(n)
    Next n
    Cells(i, 2) = t
    t = Empty
Next i
End Sub

Sub mrshkei()
Dim  arr
arr = Range("A2:A15")
For i = LBound(arr) To UBound(arr)
    x = Application.InputBox(arr(i, 1), Type:=2)
    lr = Cells(Rows.Count, 2).End(xlUp).Row + 1
    Cells(lr, 2) = x
Next i
End Sub

=I5

=M4

Sub mrshkei()
Dim i As Long, lr As Long
lr = Cells(Rows.Count, 9).End(xlUp).Row
For i = 5 To lr Step 8
    Range(Cells(i - 1, 15), Cells(i + 6, 15)) = Cells(i, 9)
Next
End Sub

Sub mrshkei()
Dim i As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 5 To lr Step 8
    Cells(i, 1).Copy Destination:=Range(Cells(i + 1, 1), Cells(i + 7, 1))
Next
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Target = Empty Then Exit Sub
If Not Intersect(Target, Range("E6:AI11")) Is Nothing Then
Dim cell As Range, sh As Worksheet
Set sh = Worksheets("Заказчик")
Set cell = sh.Columns(1).Find(Target, LookIn:=xlValues, LookAt:=xlWhole)
If Not cell Is Nothing Then
    Cells(Target.Row, Target.Column).Interior.ColorIndex = cell.Offset(0, 4).Interior.ColorIndex
    If (Cells(Target.Row, Target.Column).Comment Is Nothing) Then
        Cells(Target.Row, Target.Column).AddComment.Text "Менеджер:" & Chr(10) & cell.Offset(0, 2)
    Else
        Cells(Target.Row, Target.Column).Comment.Text "Менеджер:" & Chr(10) & cell.Offset(0, 2)
    End If
Else
    MsgBox "УКАЗАННЫЙ ПРОЕКТ НЕ НАЙДЕН"
End If
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Target = Empty Then Exit Sub
If Not Intersect(Target, Range("E6:AI11")) Is Nothing Then
Dim cell As Range, sh As Worksheet
Set sh = Worksheets("Заказчик")
Set cell = sh.Columns(1).Find(Target, LookIn:=xlValues, LookAt:=xlWhole)
If Not cell Is Nothing Then
    Cells(Target.Row, Target.Column).Interior.ColorIndex = cell.Row - 1
    If (Cells(Target.Row, Target.Column).Comment Is Nothing) Then
        Cells(Target.Row, Target.Column).AddComment.Text "Менеджер:" & Chr(10) & cell.Offset(0, 2)
    Else
        Cells(Target.Row, Target.Column).Comment.Text "Менеджер:" & Chr(10) & cell.Offset(0, 2)
    End If
    
Else
    MsgBox "УКАЗАННЫЙ ПРОЕКТ НЕ НАЙДЕН"
End If
End If
End Sub