Новости:

Теперь на форум можно залогиниться / зарегистрироваться с помощью ВКонтакте. Уже существующие пользователи могут связать свою учетную запись с аккаунтом ВКонтакте одним кликом в профиле пользователя http://forum.msexcel.ru/index.php?action=profile;area=account

Главное меню

Макрос замены, экспорта и печати из Excel в Word

Автор Bomont, 08.04.2016, 13:58

« назад - далее »

Bomont

Добрый день, использую чудесный макрос написанный не мною.

Вопрос в том, что макрос печати данных в Word зависает, когда области печати заходят за границы (причем на самом деле не критичнодля принтера). Т.е. Word выдает предупреждение о том что "поля раздела 1 выходят за границы печати.Продолжить?". Строчка кода печати "WD.PrintOut Copies:=Worksheets("Сделка").Range("C7").Value". Что добавить код, чтобы он игнорировал предупреждение и продолжал печать?

P.S. пользователь на самом деле вообще не видит Word, он открывается и отправляет на печать в скрытом режиме.

Calculate
    ct = 11 'где начинаются данные в таблице
    КоличествоОбрабатываемыхСтолбцов = 52
   
    ИмяФайлаШаблона = "Поручение на сделку.dotx"
    ПапкаСохранения = "Поручения на сделку"
    РасширениеСоздаваемыхФайлов = ".docx"
    ПутьШаблона = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона)
   
   
    Dim row As Range, pi As New ProgressIndicator
    r = Cells(Rows.Count, "A").End(xlUp).row: rc = r - ct + 1
    If rc < 1 Then MsgBox "Строк для обработки не найдено", vbCritical: Exit Sub

    pi.Show "Формирование договоров": pi.ShowPercents = True: s1 = 10: s2 = 90: p = s1: a = (s2 - s1) / rc
    pi.StartNewAction , s1, "Запуск приложения Microsoft Word"

    ' Dim WA As Word.Application, WD As Word.Document: Set WA = New Word.Application    ' c подключением библиотеки Word
    Dim WA As Object, WD As Object: Set WA = CreateObject("Word.Application")    ' без подключения библиотеки Word
    ct1 = ct
    For Each row In ActiveSheet.Rows(ct & ":" & r)
        With row
           
            ФИО = Trim$(.Cells(52))
            Filename = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ПапкаСохранения) & Application.PathSeparator & ФИО & РасширениеСоздаваемыхФайлов
           
            pi.StartNewAction p, p + a / 3, "Создание нового файла на основании шаблона", ФИО
            Set WD = WA.Documents.Add(ПутьШаблона): DoEvents

            pi.StartNewAction p + a / 3, p + a * 2 / 3, "Замена данных ...", ФИО
            For i = 1 To КоличествоОбрабатываемыхСтолбцов
                FindText = Cells(10, i): ReplaceText = Trim$(.Cells(i))

                ' так почему-то заменяет не всё (не затрагивает таблицу)
                'WA.Selection.Find.Execute FindText, , , , , , , wdFindContinue, False, ReplaceText, True

                pi.line3 = "Заменяется поле " & FindText
                With WD.Range.Find
                    .Text = FindText
                    .Replacement.Text = ReplaceText
                    .Forward = True
                    .Wrap = 1
                    .Format = False: .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                    .Execute Replace:=2
                End With
                DoEvents
            Next i
           
            If .Cells(7) = "да" Then
                pi.StartNewAction p + a * 2 / 3, p + a, "Отправка на печать", ФИО, " "
                WD.PrintOut Copies:=Worksheets("Сделка").Range("C7").Value
            End If
            If .Cells(8) = "да" Then
                pi.StartNewAction p + a * 2 / 3, p + a, "Записываем в реестр", ФИО, " "
                cr = Worksheets("Р1").UsedRange.Rows.Count
                Worksheets("Р1").Range("A" & cr + 1 & ":AZ" & cr + 1).Value = Worksheets("Сделка").Range("A" & ct1 & ":AZ" & ct1).Value
            End If
            pi.StartNewAction p + a * 2 / 3, p + a, "Сохранение файла ...", ФИО, " "
            WD.SaveAs Filename: WD.Close False: DoEvents
            ct1 = ct1 + 1
            p = p + a
        End With
    Next row

    pi.StartNewAction s2, , "Завершение работы приложения Microsoft Word", " ", " "
    WA.Quit False: pi.Hide
    'msg = "Сформировано " & rc & " файлов. Все они находятся в папке" & vbNewLine & Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ПапкаСохранения)
    'MsgBox msg, vbInformation, "Готово"

Bomont

Может кто нибудь подскажет в каком направлении хотя бы искать?