[C3]="Сменно-суточное задание на пилоотрезные станки"

dim new_book as workbook
set new_book=workbookS.ADD

Workbooks("Книга1.xlsm").Sheets("Лист1").Activate ' Активирует лист книги

Dim a As Variant, i As Long, b As Variant, k As Long ' Описывает переменные
  a = Лист1.Range("A3:D1000") ' Задаёт параметры массива
    For i = 1 To 1000
      If a(3, i) = 1 Then ' Выполнят поиск "1" в 3 столбике вышеописанного массива
      b = a(1, i) ' Если сбывается условие то присваивает переменной "b" значение из 1 столбика  
      End If
    Next
    
Workbooks(Date1 & ".xls").Sheets("Лист1").Activate
  Лист2.Range(Cells(7 + spisok1 + 1, 1), Cells(7 + spisok1 + 1 + spisok2, 1)) = b 'присваивает значение "b" соответствующим ячейкам

Sub Мяу()
    Dim ar, a()
    Dim oDic As Object, d As Object
    Dim i&, x&
    Set oDic = CreateObject("Scripting.Dictionary")
    ar = ThisWorkbook.Sheets(1).Range("C4").CurrentRegion.Value
    For i = 1 To UBound(ar)
        If Len(ar(i, 3)) Then
            If oDic.exists(ar(i, 3)) Then
                Set d = oDic.Item(ar(i, 3))
                ReDim a(1)
                a(0) = ar(i, 2)
                a(1) = ar(i, 4)
                d.Item(d.Count) = a
                Set oDic.Item(ar(i, 3)) = d
            Else
                Set d = CreateObject("Scripting.Dictionary")
                ReDim a(1)
                a(0) = ar(i, 2)
                a(1) = ar(i, 4)
                d.Item(d.Count) = a
                Set oDic.Item(ar(i, 3)) = d
            End If
        End If
    Next
    With Workbooks.Add(1)
        With .Sheets(1)
            .Range("C3").Value = "Сменно-суточное задание на пилоотрезные станки"
            .Range("C4").Value = "Дата"
            .Range("H1").Value = "Утверждаю"
            .Range("A6").Value = "Наименование оборудования"
            .Columns("A").ColumnWidth = 18
            .Columns("B").ColumnWidth = 38.89
            .Range("B6").Value = "шифр"
            .Range("C6").Value = "Количество"
            .Range("D6").Value = "операция"
            For i = 1 To oDic.Count
                x = .Cells(Rows.Count, 2).End(xlUp).Row + 1
                x = x - (x > 7)
                .Cells(x, 1).Resize(oDic(i).Count + 1).Merge
                .Cells(x, 2).Resize(oDic(i).Count, 2).Value = Application.Transpose(Application.Transpose(oDic(i).Items))
            Next
        End With
        .SaveAs Filename:="D:\" & Format(Date, "dd_mm_yyyy") & ".xlsx", FileFormat:=51
    End With
End Sub