Всем спасибо, все свободны. Код заработал. Вот итоговый вариант, если вдруг кому понадобится:
Код |
---|
Attribute VB_Name = "Module1" Sub Get_All_File_from_Folder() Dim sFolder As String, sFiles As String With Application.FileDialog(msoFileDialogFolderPicker) If .Show = False Then Exit Sub sFolder = .SelectedItems(1) End With sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator) Application.ScreenUpdating = False sFiles = Dir(sFolder & "*.xls*") Do While sFiles <> "" 'открываем книгу Workbooks.Open sFolder & sFiles 'действия с файлом Range("A6:G6").Select 'разъеденить With Selection 'ячейки Selection.UnMerge '"A6-G6" End With With ActiveSheet.PageSetup .PrintTitleRows = "$12:$14" 'сквозные строки "12-14" .PrintTitleColumns = "$A:$A" 'сквозные столбцы "A-A" End With ActiveSheet.PageSetup.PrintArea = "" With ActiveSheet.PageSetup .LeftHeader = "" .CenterHeader = "" .RightHeader = _ "&""Courier New,обычный""&9Продолжение таблицы 4.12" & Chr(10) & "Лист № &P" 'настройка верхнего колонтитула .LeftFooter = "" .CenterFooter = "" .RightFooter = "&""Courier New,обычный""&8&F" 'настройка нижнего колонтитула .LeftMargin = Application.InchesToPoints(0.393700787401575) 'настройка поля (левое) .RightMargin = Application.InchesToPoints(0.393700787401575) 'настройка поля (правое) .TopMargin = Application.InchesToPoints(1.18110236220472) 'настройка поля (верхнее) .BottomMargin = Application.InchesToPoints(0.393700787401575) 'настройка поля (нижнее) .HeaderMargin = Application.InchesToPoints(0.78740157480315) 'настройка поля (верхнего колонтитула) .FooterMargin = Application.InchesToPoints(0.196850393700787) 'настройка поля (нижнего колонтитула) .PrintHeadings = False .PrintGridlines = False .PrintComments = xlPrintNoComments .PrintQuality = 600 .CenterHorizontally = True .CenterVertically = False .Orientation = xlLandscape 'ставим ориентацию страницы - АЛЬБОМ .Draft = False .PaperSize = xlPaperA4 .FirstPageNumber = xlAutomatic .Order = xlOverThenDown .BlackAndWhite = False .Zoom = 78 'настраиваем МАСШТАБ страницы .PrintErrors = xlPrintErrorsDisplayed .OddAndEvenPagesHeaderFooter = False .DifferentFirstPageHeaderFooter = True .ScaleWithDocHeaderFooter = True .AlignMarginsHeaderFooter = False .EvenPage.LeftHeader.Text = "" .EvenPage.CenterHeader.Text = "" .EvenPage.RightHeader.Text = "" .EvenPage.LeftFooter.Text = "" .EvenPage.CenterFooter.Text = "" .EvenPage.RightFooter.Text = "" .FirstPage.LeftHeader.Text = "" .FirstPage.CenterHeader.Text = "" .FirstPage.RightHeader.Text = _ "&""Courier New,обычный""&9Таблица 4.12" & Chr(10) & "На &N листах" 'настройка колонтитула первой страницы .FirstPage.LeftFooter.Text = "" .FirstPage.CenterFooter.Text = "" .FirstPage.RightFooter.Text = "" End With Range("A31").Select ActiveCell.FormulaR1C1 = "Из общей" & Chr(10) & "численности - " & Chr(10) & "население" & Chr(10) & "в возрасте:" 'удаление ошибочных квадратиков With ActiveCell.Characters(Start:=1, Length:=45).Font Range("L13").Select ActiveCell.FormulaR1C1 = "сбережения;" & Chr(10) & "дивиденды; проценты" 'удаление ошибочных квадратиков With ActiveCell.Characters(Start:=1, Length:=31).Font End With Range("N13").Select ActiveCell.FormulaR1C1 = _ "на иждивении" & Chr(10) & "отдельных лиц; помощь других лиц; алименты" 'удаление ошибочных квадратиков With ActiveCell.Characters(Start:=1, Length:=55).Font End With Range("O13").Select ActiveCell.FormulaR1C1 = "иной источ-" & Chr(10) & "ник средств к суще-" & Chr(10) & "ствова-" & Chr(10) & "нию" 'удаление ошибочных квадратиков With ActiveCell.Characters(Start:=1, Length:=43).Font Rows("6:6").Select 'удалить Selection.Delete Shift:=xlUp 'строку "6" Range("A14:T38").Select '9 With Selection.Font 'шрифт .Name = "Courier New" 'в .Size = 9 'таблице Range("A10").Select End With End With End With sFiles = Dir Loop Application.ScreenUpdating = True ActiveWorkbook.Save 'сохраняем документ ActiveWindow.Close 'закрываем документ End Sub |