Всем спасибо, все свободны. Код заработал. Вот итоговый вариант, если вдруг кому понадобится:
| Код |
|---|
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
|
