Private Sub ИмяЛСР2_Change()
        With ИмяЛСР2
           .AddItem ИмяЛСР2.Text
        End With
End Sub

Private Sub ИмяЛСР2_Change()
    Dim sText As String
    With ИмяЛСР2
        sText = Trim$(ИмяЛСР2.Value)
        .AddItem sText
    End With
End Sub

.MoveFile myFiles(i), newFolder

    For i = Worksheets.Count To 2 Step -1 ' Проход по листам
        iDate = Worksheets(i).Name
        For z = 1 To UBound(task)
            Set Findtask1 = Worksheets(i).UsedRange.Find(task(z), , xlValues, xlPart) ' начало блока
            If z = UBound(task) Then
                lastrow = Cells(Rows.Count, 3).End(xlUp).Row
                Set Findtask2 = Cells(lastrow + 1, 3)
                    Else
                Set Findtask2 = Worksheets(i).UsedRange.Find(task(z + 1), , xlValues, xlPart) ' конец блока
            End If
            For x = Findtask1.Row + 1 To Findtask2.Row - 1
                If IsEmpty(Cells(x, 3)) = False Then
                Worksheets(i).Activate
                Set NewRow = tbl.ListRows.Add
                    With NewRow.Range
                      .Columns(1).Value = iDate
                      .Columns(2).Value = Sheets(i).Cells(x, 2).Value
                      .Columns(3).Value = Findtask1
                      .Columns(4).Value = Sheets(i).Cells(x, 3).Value
                      .Columns(5).Value = Sheets(i).Cells(x, 4).Value
                      .Columns(6).Value = Sheets(i).Cells(x, 5).Value
                      .Columns(7).Value = Sheets(i).Cells(x, 6).Value
                      .Columns(8).Value = Sheets(i).Cells(x, 7).Value
                    End With
                End If
            Next x
        Next z
    Next i

.FirstPage.RightHeader.Text = _         "&""Times New Roman,обычный""&14&UТратата_"

.FirstPage.LeftHeader.Text = .EvenPage.LeftHeader.Text

.FirstPage.LeftHeader.Text = .EvenPage.LeftHeader.Text.Value

Sub ListPrnt()
Dim lprnt(), t As Single
'Dim vTimeout
Const vTimeout = 3
k = [C4].Value ' кол-во экземпляров
Pt = [C8] ' Принтер
    With Selection
    ReDim lprnt(1 To Selection.Count)
    For x = 1 To k ' кол-во экземпляров
        For i = 1 To Selection.Count
'            lprnt(i) = Selection(i) ' это я хотел через массив оформить, передумал
            CreateObject("Shell.Application").ShellExecute _
            Selection(i), "", "", "Print", 0&
            t = Timer + vTimeout
            While Timer < t
              DoEvents
            Wend
        Next
        Next
    End With
End Sub 

Private Sub ButtonSetKoef_Click()
' ///////////формула коэф-тов
    Dim Msg As String
    Dim i As Integer

    If ListBoxKoef.ListIndex = -1 Then
        Msg = "Ничего не выделено"
    Else
        Msg = ""
        For i = 0 To ListBoxKoef.ListCount - 1 '  работает
            If ListBoxKoef.Selected(i) Then _
              Msg = Msg & ListBoxKoef.List(i) & vbCrLf '  работает, но выводит толькой 1-й столбец
             
        Next i
    End If
    MsgBox "Вы выбрали: " & vbCrLf & Msg
End Sub

             If ListBoxKoef.Selected(i) Then _
              Msg = Msg & ListBoxKoef.List(ListBoxKoef.ListIndex, 3) & vbCrLf

Selection.FormulaR1C1 = "=1+(1.02-1)+(1.04-1)" 'образец

Dim fso As Scripting.FileSystemObject

Sub Backup()
    iPath$ = "z:\eee\hhhh\jjjj\"
    iFileName$ = ActiveWorkbook.Name

    ActiveWorkbook.Save

    iFileName$ = Left(iFileName$, Len(iFileName$) - 4) & "xlsx"
    ActiveWorkbook.SaveAs Filename:= _
        iPath$ & iFileName$, FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
    
End Sub

Sub Backup_Active_Workbook()
    Dim x As String
    strPath = "z:\eee\hhhh\jjjj"     'папка для сохранения резервной копии
    On Error Resume Next
    x = GetAttr(strPath) And 0
    If Err = 0 Then ' если путь существует - сохраняем копию книги, добавляя дату-время
        FileNameXls = strPath & "\" & "AAAA" & ".xlsx"
        ActiveWorkbook.SaveCopyAs Filename:=FileNameXls
    Else 'если путь не существует - выводим сообщение
        MsgBox "Папка " & strPath & " недоступна или не существует!", vbCritical
    End If
End Sub

Sub Смета_Ф()
......

Dim Ind2 As Double

Ind2 = 6.9
......
Cells(x + 15, 11).FormulaR1C1 = "=R[-3]C/6.9" ' работает
Cells(x + 15, 11).FormulaR1C1 = "=R[-3]C/Ind2" ' не работает, ошибка #ИМЯ? на листе
Cells(x + 15, 11).FormulaR1C1 = "=R[-3]C/" & Ind2 ' не работает ошибка кода 1004
......

Dim pg As Integer ' кол-во страниц
...
ActiveWindow.SelectedSheets.PrintPreview ' Требуется ручное закрытие предпросмотра
pg = ActiveWorkbook.Worksheets(1).HPageBreaks.Count + 1

Sub General_Work()
Dim dLastRow As Long, sLastRow As Long, sSheet As String, Mounth As String, sPath As String, sFileName As String
Set dbk = Application.ActiveWorkbook
Mounth = Sheets(1).Cells(2, 7) ' ячейка в которой указан необходимый месяц
dLastRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    sPath = "D:\отдел\"
    sFileName = "реестр.xls"
    Workbooks.Open Filename:=sPath & sFileName, _
        ReadOnly:=True
Set sbk = Application.ActiveWorkbook
sLastRow = Sheets("ВЫП " & Mounth & " ").Cells(Rows.Count, 2).End(xlUp).Row 'работает, нужен подст симв
' sLastRow = Sheets("ВЫП " & Mounth & "*").Cells(Rows.Count, 2).End(xlUp).Row 'не работает

MsgBox " Последняя строка: " & sLastRow
End Sub