значение из экселя в переменную ворд

[staniiislav]

Доброго времени суток, Ув. Форумчане
Подскажите пожалуйста, как из значения ячейки (cells(1,1)) активного листа передать в переменную ворд это значение (точнее присвоить переменной col значение cells(1,1)).
Попробовал через Public в экселе, не получилось... в интернете мало что написано ((((
Спасибо

[EducatedFool]

А макрос из Word запускается?
Как получаете доступ к запущенному приложению Excel?

Лень писать код целиком - покажите что есть, мы подправим.

[staniiislav]

есть Ваш код ))) CreateWordDocuments2

Const ИмяФайлаШаблона = "шаблон.dot"
Const КоличествоОбрабатываемыхСтолбцов = 8
Const РасширениеСоздаваемыхФайлов = ".doc"

Sub СформироватьДоговоры()
    ПутьШаблона = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, ИмяФайлаШаблона)
    НоваяПапка = NewFolderName & Application.PathSeparator
    Dim row As Range, pi As New ProgressIndicator
    r = Cells(Rows.Count, "A").End(xlUp).row: rc = r - 2
    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

    For Each row In ActiveSheet.Rows("3:" & r)
        With row
            ФИО = Trim$(.Cells(1)) & " " & Trim$(.Cells(2)) & " " & Trim$(.Cells(3))
            Filename = НоваяПапка & ФИО & РасширениеСоздаваемыхФайлов

            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(1, 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
            pi.StartNewAction p + a * 2 / 3, p + a, "Сохранение файла ...", ФИО, " "
            WD.SaveAs Filename: WD.Close False: DoEvents
            p = p + a
        End With
    Next row

    pi.StartNewAction s2, , "Завершение работы приложения Microsoft Word", " ", " "
    WA.Quit False: pi.Hide
    msg = "Сформировано " & rc & " договоров. Все они находятся в папке" & vbNewLine & НоваяПапка
    MsgBox msg, vbInformation, "Готово"
End Sub

Function NewFolderName() As String
    NewFolderName = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "Договоры, сформированные " & Get_Now)
    MkDir NewFolderName
End Function

Function Get_Date() As String: Get_Date = Replace(Replace(DateValue(Now), "/", "-"), ".", "-"): End Function
Function Get_Time() As String: Get_Time = Replace(TimeValue(Now), ":", "-"): End Function
Function Get_Now() As String: Get_Now = Get_Date & " в " & Get_Time: End Function

только в место

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

пытаюсь в ворде сделать так:

Sub shUp()

Dim rng As Range
Dim sh As Shape, b
For Each sh In ActiveDocument.Shapes
    b = sh.Name
    With sh.TextFrame
        If .HasText <> 0 Then
            Set rng = .TextRange
            rng.Find.Text = FindText
            rng.Find.Execute
            If rng.Find.Found Then
               rng.Text = ReplaceText
            End If
        End If
    End With
Next sh

End Sub

[EducatedFool]

А зачем вам мой код?

Мой код подставляет данные из Excel в Word, но будучи запущенным из Excel

Если вы намерены сделать всё в стиле «per rectum», забирая макросом в ворде данные из Excel, то макрос надо переписывать «с нуля»

И мне надо видеть не мой макрос, и ваш, вордовский.
И не это - Sub shUp()
А нормальный большой макрос, который подключается к открытому Excel
через GetObject(,"Excel.Application"), чтобы взять из него данные.

--------------------------

PS: Ну а всем остальным читателям этой темы, кому надо формировать документы, но лень часами ковыряться в коде макросов,
предложу готовое решение, позволяющее заполнить документы Word нажатием одной кнопки:
http://excelvba.ru/programmes/FillDocuments

--------------------------

[staniiislav]

Сообщение от EducatedFool

готовое решение, позволяющее заполнить документы Word нажатием одной кнопки:
http://excelvba.ru/programmes/FillDocuments

сейчас попробуем готовое решение. спасибо за ответ.
Я смотрел по вашему коду, как вы делаете открытие документа.
Спасибо Вам большое!

[staniiislav]

EducatedFool, не могу скачать ваш фаил:
http://excelvba.ru/programmes/FillDocuments
в место скачивания просто открывается пустая страничка... Не знаете в чем может быть проблема?

[EducatedFool]

Какой браузер? какой версии?
Вроде как, во всех браузерах нормально скачивается.

Прямая ссылка на загрузку сегодняшней версии программы:
http://excelvba.ru/updates/FillDocum...ents_v2129.xla


PS: Правда, моя программа пока не умеет подставлять данные в фигуры в Word
Это можно реализовать, но... форматирвоание текста фигуры, если оно различается для разных слов, будет скидываться.
Чтобы сохранить форматирование текста в фигуре (например, первое слово - жирным шрифтом, второе - нет, а третье - вообще красное),
придется заметно усложнять код.

[staniiislav]

Сообщение от EducatedFool

Какой браузер? какой версии?
Вроде как, во всех браузерах нормально скачивается.

Прямая ссылка на загрузку сегодняшней версии программы:
http://excelvba.ru/updates/FillDocum...ents_v2129.xla


PS: Правда, моя программа пока не умеет подставлять данные в фигуры в Word
Это можно реализовать, но... форматирвоание текста фигуры, если оно различается для разных слов, будет скидываться.
Чтобы сохранить форматирование текста в фигуре (например, первое слово - жирным шрифтом, второе - нет, а третье - вообще красное),
придется заметно усложнять код.

понял... да может и без фигур смогу обойтись... на пробовать все.
на работе админы наверное опять играются ))) в обед попробую...
Будем думать. Спасибо

[SirSAS]

Сообщение от staniiislav

Доброго времени суток, Ув. Форумчане
Подскажите пожалуйста, как из значения ячейки (cells(1,1)) активного листа передать в переменную ворд это значение (точнее присвоить переменной col значение cells(1,1)).
Попробовал через Public в экселе, не получилось... в интернете мало что написано ((((
Спасибо

Добрый день! У меня тоже актуально встал этот вопрос.
1. Есть файл исходных данных и параметров Excel
2. Есть шаблон Word, который трансформируется в зависимости от некоторых параметров Excel

Подскажите, как мне получить значение ячейки в переменную макроса Word?

Я сделал это путем вставки связанной ячейки и проверки поля, но хотелось бы обойтись без этих лишних манипуляций. Привожу свой код:

Dim oFld As Field
   
    For Each oFld In ActiveDocument.Fields
    If oFld.Type = wdFieldLink Then 'Если поле является полем ссылки
        If InStr(oFld.Code.Text, "R1C8") <> 0 Then 'Если поле ссылается на ячейку Excel
            oFld.Code.Select
            Selection.Fields.Update
            If oFld.Result.Text = 1 Then NDSvalue = True Else: NDSvalue = False
        Exit For
        End If
    End If
    Next

[maksim_serg]

я этой пользуюсь
формирование документов word по шаблону из Excel
http://programmy.bb777.ru/index.php?id=60