Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Как применить макрос к нескольким книгам одновременно?, Предпечатная обработка файла
 
#1
31.08.2014 19:03:08
У меня есть тысячи xls-таблиц определённого содержания. Их все нужно распечатать.
Для того что бы распечатать эти таблицы предварительно нужно подготовить их к печати (удалить лишний столбец, заменить строку, проставить колонтитулы, настроить поля, установить масштаб и прочее).
Я сделал 2 макроса с горячими клавишами. Но это всё-равно неудобно. Возможно сделать так, что бы эти 2 макроса автоматически сработали на всех этих
файлах с xls-таблицами?

Прилагаю 2 модуля с макросами (1 макрос на Ctrl-W и 2 макрос на Ctrl+Q),
и 2 таблицы:
- одну которую нужно распечатать, предварительно запустив эти 2 макроса на ней.
04-11_ Уральский ГО_СН_Русские_Оба_Все [ТАК ЕСТЬ].xls
- И как должна выглядеть таблица после срабатывания этих макросов:
04-11_Уральский ГО_СН_Русские_Оба_Все [ТАК ДОЛЖНО БЫТЬ].xls

В идеале хочется, что бы 1 макрос автоматически сработал на всех таблицах, а я потом, нажав правую кнопку мыши на файле и выбрав "Печать", распечатал эти файлы.
Хочется научиться именно ТЕХНОЛОГИИ автоматической предпечатной обработки файлов в excel.
Потому что в следующих таблицах возможно надо будет делать другую предпечатную обработку.

Чем проще это будет - тем лучше.
Изменено: stat74 - 31.08.2014 19:27:33
 
 
 
#2
31.08.2014 19:29:53
http://www.programmersforum.ru/showthread.php?t=114304
Цитата
Не рекомендуется: 4.1. Создавать одинаковые темы или сообщения в разных форумах (cross-posting). Публикуя один и тот же вопрос в разных форумах и на дружественных сайтах вы заставляете сразу нескольких людей параллельно думать над вашей задачей и обесцениваете усилия тех, кто даст ответ вторым-третьим и т.д.
 
 
 
#3
01.09.2014 16:38:18
Цитата
stat74 пишет:
Хочется научиться именно ТЕХНОЛОГИИ
Если эти "тысячи таблиц" в одном файле, то перед печатью, в модуле книги Workbook_BeforePrint проходим циклом по листам (и/или таблицам) и выполняем макрос для каждого листа (таблицы).
Если это тысяча файлов с одной (или не одной) таблицей в каждом, то циклом проходим по файлам. Желательно, что-бы они находились в одной папке (при необходимости цикл по листам\таблицам в каждом файле) и выполняем макрос для каждого файла.

З.Ы. Ваши два макроса можно объединить
Код
Sub PrePrint()
On Error Resume Next
    [C14].Value = "после-" & Chr(10) & "вузов-" & Chr(10) & "ское"
    [F15].Value = "специа-" & Chr(10) & "лист"
    With Union([C14], [F15]).Font
        .Name = "Courier New"
        .FontStyle = "полужирный"
        .Size = 8
    End With
    
    Columns("A:A").Delete Shift:=xlToLeft

    With ActiveSheet.PageSetup
        .PrintTitleRows = "$12:$17"
        .PrintTitleColumns = "$A:$A"
        .RightHeader = "&""Courier New,обычный""&9Продолжение таблицы 4.11" & Chr(10) & "Лист № &P"
        .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)
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .PaperSize = xlPaperA4
        .Order = xlOverThenDown
        .BlackAndWhite = False
        .Zoom = 100
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = True
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = False
        .FirstPage.RightHeader.Text = "&""Courier New,обычный""&9Таблица 4.11" & Chr(10) & "На &N листах"
    End With
End Sub
Согласие есть продукт при полном непротивлении сторон
 
 
 
#4
01.09.2014 19:15:25
Да, именно что тысячи файлов с одной таблицей в каждом и находятся они в одной папке. Что значит циклом проходим по файлом? Что-то нужно добавить в макрос? Благодарю за помощь.
Изменено: stat74 - 01.09.2014 19:45:34
 
 
 
#5
02.09.2014 09:52:35
Цитата
stat74 пишет: Что значит циклом проходим по файлом?
посмотрите статью и первый код по ссылке
вместо 15-й строки первого кода вставляете то, что вы хотите сделать с файлом
F1 творит чудеса
 
 
 
#6
02.09.2014 18:12:18
Цитата
Максим Зеленский пишет:
вместо 15-й строки первого кода вставляете то, что вы хотите сделать с файлом
Благодарю, буду разбираться.
 
 
 
#7
03.09.2014 15:50:18
Макрос заработал. Добавил в конец макроса:
Код
  ActiveWorkbook.Save 'сохраняем документ
  ActiveWindow.Close 'закрываем документ
И при сохранение выскакивает вот такое окно:


Как в макросе прописать нажатие клавиши "Продолжить"?
В параметрах Excel (Сохранение) не нашёл этой настройки.
Изменено: stat74 - 03.09.2014 15:52:58
 
 
 
#8
03.09.2014 16:15:21
Цитата
stat74 пишет: ActiveWindow.Close 'закрываем документ
Код
ActiveWorkbook.Close   'закроет документ
Application.Quit 'закроет xl
Изменено: JeyCi - 03.09.2014 16:18:32
чтобы не гадать на кофейной гуще, кто вам отвечает и после этого не совершать кучу ошибок - обратитесь к собеседнику на ВЫ - ответ на ваш вопрос получите - а остальное вас не касается (п.п.п. на форумах)
 
 
 
#9
03.09.2014 16:17:13
В начале макроса отключите сообщения
Код
Application.DisplayAlerts = False
Согласие есть продукт при полном непротивлении сторон
 
 
 
#10
03.09.2014 19:54:24
И не забудьте включить в конце, а то мало ли :)
F1 творит чудеса
 
 
 
#11
04.09.2014 08:39:21
Максим Зеленский, из встроенной справки VBA:
Цитата
If you set this property to False, Microsoft Excel sets this property to True when the code is finished....
но включить ошибкой не будет, а то мало ли  ;)
Согласие есть продукт при полном непротивлении сторон
 
 
 
#12
04.09.2014 16:40:43
Всем спасибо, все свободны. Код заработал. Вот итоговый вариант, если вдруг кому понадобится:
Код
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
 
 
 
Страницы: 1
Наверх