[SIZE=8pt]Sub Main()[/SIZE]
[SIZE=8pt]    Dim SourceFolder As String, DestinationFolder As String, ce As Range[/SIZE]
[SIZE=8pt]    InitialPath = ThisWorkbook.Path: Dim coll As New Collection[/SIZE]
[SIZE=8pt]    Application.ScreenUpdating = False[/SIZE]

[SIZE=8pt]    SourceFolder = GetFolderPath("Выберите исходную папку для поиска файлов", InitialPath)[/SIZE]
[SIZE=8pt]    If SourceFolder = "" Then MsgBox "Необходимо указать папку!", vbCritical, "Папка не выбрана": Exit Sub[/SIZE]

[SIZE=8pt]    DestinationFolder = GetFolderPath("Выберите папку, в которую будет производиться копирование", SourceFolder)[/SIZE]
[SIZE=8pt]    If DestinationFolder = "" Then MsgBox "Необходимо указать папку!", vbCritical, "Папка не выбрана": Exit Sub[/SIZE]

[SIZE=8pt]    On Error Resume Next[/SIZE]
[SIZE=8pt]    If Dir(DestinationFolder, vbDirectory) = "" Then MkDir DestinationFolder    ' если конечная папка не существует, создаём её[/SIZE]

[SIZE=8pt]    Filename = Dir(SourceFolder & "*.xls")[/SIZE]
[SIZE=8pt]    Dim wb As Workbook, sh As Worksheet[/SIZE]
[SIZE=8pt]    While Filename <> ""[/SIZE]
[SIZE=8pt]        coll.Add Filename: Filename = Dir[/SIZE]
[SIZE=8pt]    Wend[/SIZE]

[SIZE=8pt]    For Each file In coll[/SIZE]
[SIZE=8pt]        Set wb = Workbooks.Open(SourceFolder & file, , True)[/SIZE]
[SIZE=8pt]        Application.StatusBar = "Обрабатывается файл  " & file    ' вывод информации в строку состояния[/SIZE]
[SIZE=8pt]        Set sh = wb.Worksheets(3) ' замените на Set sh = wb.Worksheets(1)[/SIZE]
[SIZE=8pt]        NewFilename = НовоеИмяФайла(sh.Cells(3, 4), sh.Cells(12, 4))[/SIZE]
[SIZE=8pt]        wb.SaveAs DestinationFolder & NewFilename[/SIZE]
[SIZE=8pt]        wb.Close False[/SIZE]
[SIZE=8pt]    Next[/SIZE]

[SIZE=8pt]    Application.StatusBar = ""[/SIZE]
[SIZE=8pt]End Sub[/SIZE]

[SIZE=8pt]Function НовоеИмяФайла(ByVal cell2 As String, ByVal cell8 As String) As String[/SIZE]

[SIZE=8pt]    arr = Split(cell3, " ")[/SIZE]
[SIZE=8pt]    For i = LBound(arr) To UBound(arr)[/SIZE]
[SIZE=8pt]        НовоеИмяФайла = НовоеИмяФайла & Left(arr(i), 1)[/SIZE]
[SIZE=8pt]    Next[/SIZE]
[SIZE=8pt]    НовоеИмяФайла = UCase(НовоеИмяФайла)[/SIZE]

[SIZE=8pt]    дата = Split(cell12, " ")(1)[/SIZE]
[SIZE=8pt]    If IsDate(дата) Then НовоеИмяФайла = НовоеИмяФайла & " " & LCase(Format(дата, "MMMM YYYY"))[/SIZE]
[SIZE=8pt]    НовоеИмяФайла = НовоеИмяФайла & ".xls"[/SIZE]
[SIZE=8pt]End Function[/SIZE]

[SIZE=8pt]Function GetFolderPath(Optional ByVal Title As String = "Выберите папку", Optional ByVal InitialPath As String = "c:\") As String[/SIZE]
[SIZE=8pt]    GetFolderPath = "": PS = Application.PathSeparator[/SIZE]
[SIZE=8pt]    With Application.FileDialog(msoFileDialogFolderPicker)[/SIZE]
[SIZE=8pt]        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath[/SIZE]
[SIZE=8pt]        If .Show = -1 Then GetFolderPath = .SelectedItems(1): If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS[/SIZE]
[SIZE=8pt]    End With[/SIZE]
[SIZE=8pt]End Function[/SIZE]