Sub Макрос1()
Range("A:A").Select
    Selection.Replace What:="=", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
End Sub

Sub mrshkei()
Dim i As Long, arr, arr2, lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
arr = Range("A3:D" & lr)
x = 0: j = 1
ReDim arr2(1 To Application.WorksheetFunction.Sum(Range("D1:D" & lr)), 1 To 2)
For i = LBound(arr) To UBound(arr)
    For n = 1 To arr(i, 4)
        arr2(j, 1) = arr(i, 1)
        arr2(j, 2) = arr(i, 2)
        j = j + 1
    Next n
Next i
Range("H3").Resize(UBound(arr2), 2) = arr2
End Sub

Sub mrshkei()
Dim i As Long, arr, arr2, lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
arr = Range("A1:B" & lr)
x = 0: j = 1
ReDim arr2(1 To Application.WorksheetFunction.Sum(Range("B1:B" & lr)), 1 To 1)
For i = LBound(arr) To UBound(arr)
    For n = 1 To arr(i, 2)
        arr2(j, 1) = arr(i, 1)
        j = j + 1
    Next n
Next i
Range("C1").Resize(UBound(arr2), 1) = arr2
End Sub

Sub Кнопка2_Щелчок()
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & [B3] & ".xlsx"
End Sub

=СЧЁТЕСЛИМН($E$5:$E$9;">="&$A14;$E$5:$E$9;"<="&$A14+3;$F$5:$F$9;$B14)

Sub mrshkei()
Dim arr1, arr2, arr3, arr4, i As Long, j As Long, cell As Range, x As Long, CEL As Range
arr1 = Range("J2:N12")
arr2 = Range("Q2:W12")
ReDim arr3(1 To UBound(arr2), 1 To 1)
ReDim arr4(1 To UBound(arr2), 1 To 1)
For i = LBound(arr2) To UBound(arr2)
    arr3(i, 1) = arr2(i, 1) & ":" & arr2(i, 2) & ":" & arr2(i, 3)
    arr4(i, 1) = arr1(i, 1) & ":" & arr1(i, 2) & ":" & arr1(i, 3)
Next i
Range("O2").Resize(UBound(arr3), 1) = arr3
Range("v2").Resize(UBound(arr3), 1) = arr4
i = 1

For j = LBound(arr2) To UBound(arr2)
    Set cell = Range("O1").Resize(UBound(arr4) + 1, 1).Find(arr4(j, 1))
    If Not cell Is Nothing Then
        x = Application.WorksheetFunction.CountIf(Range("v1:v" & j + 1), cell) - 1
        arr2(i, 6) = arr1(cell.Row - 1 + x, 4)
        arr2(i, 7) = arr1(cell.Row + -1 + x, 5)
        i = i + 1
    End If
Next j
Range("A2").Resize(UBound(arr2), 7) = arr2
Range("O2").Resize(UBound(arr3), 1).Clear
Range("v2").Resize(UBound(arr3), 1).Clear
End Sub

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