Из файла xls/xlsx взять выбранную пользователем строку и создать документ docx

@xenohunter · Регистрация: 10.04.2013

Author24 — интернет-сервис помощи студентам

Здравствуйте! Возник довольно примитивный вопрос, но никак не получается найти ответ. Можно ли с помощью VBA провернуть следующую схему: из файла .xls/.xlsx с некоторым количеством строк взять выбранную пользователем строку и создать документ .docx, опираясь на данные, хранящиеся в этой строке? Более того: можно ли добавить в файл .docx изображение, путь к которому хранится в одном из полей исходной строки?
Заранее спасибо!

shanemac51 · 11.09.2014, 09:11

пример в студию(пару строк с картинками)
====
кстати, какой у картинок --размер(типа иконок или солидный)

@mc-black · 11.09.2014, 09:41

Можно. Специалисту в VBA для этого понадобится от 15 минут до пары часов времени, включая тестирование. Это при наличии полного ТЗ, исключении всех вопросов, возникающих в процессе написания, наличии файлов примеров для обработки, на которых можно произвести тестирование. На этом форуме вам помогут сделать примерно за 1-2 дня, если дадите людям файлы примеров и полное описание задачи.

@mc-black · 11.09.2014, 09:47

Вот пример пары макросов, которые по набору строк в таблице делают по 2-3 документа в Word и Excel, плюс формируют сводный список - опись сгенерированных документов для сопроводительного письма.

Кликните здесь для просмотра всего текста

Visual Basic

Option Explicit
 
Sub EnumTORG12()
    Dim lr As ListRow, wbk As Workbook, wdt As Date, dst As Worksheet
    Dim wrd As Word.Application, doc As Word.Document, sNum As String
    Dim sum As String, vdt As Date
    
    wdt = Now() + 2 ' Текущая дата + 2 дня используется для даты выставления счетов
    For Each lr In ThisWorkbook.Worksheets("ТН").ListObjects(1).ListRows
        With lr.Range
            If Trim$(.Cells(1, 21)) <> "" Then
            
            ' Создание книги по шаблону
            If .Cells(1, 15) = 500 Then
                Set wbk = Workbooks.Add(ThisWorkbook.Path & "\шаблоны\Счет 500.xltx")
            ElseIf .Cells(1, 15) = 700 Then
                Set wbk = Workbooks.Add(ThisWorkbook.Path & "\шаблоны\Счет 700.xltx")
            Else
                Debug.Print "Не указан нормер контракта в cтроке " & .Row
                Stop
            End If
            
            ' Работа по заполнению счета
            Set dst = wbk.Worksheets(1)
            
            ' Номер и дата счета
            sNum = .Cells(1, 21) ' Сохранить номер счета
            dst.Cells(3, 5) = dst.Cells(3, 5) & sNum & " от " & Format(wdt, "dd.mm.yyyy")
            ' Номер товарной накладной (торг-12)
            dst.Cells(17, 6) = dst.Cells(17, 6) & Trim$(.Cells(1, 1))
            ' Дата товарной накладной (торг-12)
            dst.Cells(19, 6) = CDate(.Cells(1, 2))
            ' Сумма товарной накладной в долларах США с учетом НДС
            dst.Cells(32, 6) = CDate(.Cells(1, 8))
            sum = Replace(LTrim$(Format$(dst.Cells(40, 6), "### ### ### ##0.00")), " ", "^s")
            ' Дата валютирования
            vdt = CDate(.Cells(1, 3))
            dst.Cells(43, 6) = vdt
            ' СТ-1, СС, СПСП
            dst.Cells(49, 2) = .Cells(1, 19)
            
            ' Завершение заполнения счета
            Set dst = Nothing
            
            ' Сохранение книг на диск
            If .Cells(1, 15) = 500 Then
                wbk.SaveAs ThisWorkbook.Path & "\Счет 77-598_1200500-О-" & _
                    sNum & " от " & Format(wdt, "dd.mm.yyyy") & ".xlsx"
            ElseIf .Cells(1, 15) = 700 Then
                wbk.SaveAs ThisWorkbook.Path & "\Счет 77-598_1110700-О-" & _
                    sNum & " от " & Format(wdt, "dd.mm.yyyy") & ".xlsx"
            Else
                Debug.Print "Не указан нормер контракта в cтроке " & .Row
                Stop
            End If
            
            ' Закрыть книгу, освободить объект
            wbk.Close False
            Set wbk = Nothing
            
            ' ----------------------------------------
            
            ' Работа по заполнению письма-поручения
            Set wrd = New Word.Application
            wrd.Visible = True
            
            ' Создание документа по шаблону
            If .Cells(1, 15) = 500 Then
                Set doc = wrd.Documents.Add(ThisWorkbook.Path & "\шаблоны\Письмо 500.dotx")
            ElseIf .Cells(1, 15) = 700 Then
                Set doc = wrd.Documents.Add(ThisWorkbook.Path & "\шаблоны\Письмо 700.dotx")
            Else
                Debug.Print "Не указан нормер контракта в cтроке " & .Row
                Stop
            End If
            
            With wrd.Selection.Find
                .ClearFormatting
                .Replacement.ClearFormatting
                ' Вставка номера счета
                .Text = "%number%"
                .Replacement.Text = sNum
                .Execute Replace:=wdReplaceAll
                ' Вставка даты счета
                .Text = "%date%"
                .Replacement.Text = Format(wdt, "dd.mm.yyyy")
                .Execute Replace:=wdReplaceAll
                ' Вставка суммы счета в 2-х местах
                .Text = "%summa%"
                .Replacement.Text = sum
                .Execute Replace:=wdReplaceAll
            End With
            
            
            ' Сохранение документов на диск
            If .Cells(1, 15) = 500 Then
                doc.SaveAs2 ThisWorkbook.Path & "\Письмо в ВЭБ 500-О-" & sNum & " от " & _
                    Format(wdt, "dd.mm.yyyy") & ".docx", wdFormatDocumentDefault
            ElseIf .Cells(1, 15) = 700 Then
                doc.SaveAs2 ThisWorkbook.Path & "\Письмо в ВЭБ 700-О-" & sNum & " от " & _
                    Format(wdt, "dd.mm.yyyy") & ".docx", wdFormatDocumentDefault
            Else
                Debug.Print "Не указан нормер контракта в cтроке " & .Row
                Stop
            End If
            
            ' Закрыть документ
            doc.Close False
            Set doc = Nothing
            
            ' ----------------------------------------
            
            ' Оформить СПД, если НДС = 0%
            If .Cells(1, 5) = 0 Then
                ' Создание документа по шаблону
                If .Cells(1, 15) = 500 Then
                    Set doc = wrd.Documents.Add(ThisWorkbook.Path & "\шаблоны\СПД 500.dotx")
                ElseIf .Cells(1, 15) = 700 Then
                    Set doc = wrd.Documents.Add(ThisWorkbook.Path & "\шаблоны\СПД 700.dotx")
                Else
                    Debug.Print "Не указан нормер контракта в cтроке " & .Row
                    Stop
                End If
                
                
                With wrd.Selection.Find
                    .ClearFormatting
                    .Replacement.ClearFormatting
                    ' Вставка даты СПД
                    .Text = "%date1%"
                    .Replacement.Text = Format(wdt, "dd.mm.yyyy")
                    .Execute Replace:=wdReplaceAll
                    ' Вставка номера счета
                    .Text = "%num%"
                    .Replacement.Text = sNum
                    .Execute Replace:=wdReplaceAll
                    ' Вставка даты валютирования счета
                    .Text = "%date2%"
                    .Replacement.Text = Format(vdt, "dd.mm.yyyy")
                    .Execute Replace:=wdReplaceAll
                    ' Вставка суммы счета
                    .Text = "%sum%"
                    .Replacement.Text = sum
                    .Execute Replace:=wdReplaceAll
                    ' Вставка даты валютирования в абзаце СПД
                    .Text = "%date3%"
                    .Replacement.Text = Format(vdt, "dd mmmm yyyy")
                    .Execute Replace:=wdReplaceAll
                End With
                
                ' Сохранение документов на диск
                If .Cells(1, 15) = 500 Then
                    doc.SaveAs2 ThisWorkbook.Path & "\СПД по счету 500-О-" & sNum & " от " & _
                        Format(wdt, "dd.mm.yyyy") & ".docx", wdFormatDocumentDefault
                ElseIf .Cells(1, 15) = 700 Then
                    doc.SaveAs2 ThisWorkbook.Path & "\СПД по счету 700-О-" & sNum & " от " & _
                        Format(wdt, "dd.mm.yyyy") & ".docx", wdFormatDocumentDefault
                Else
                    Debug.Print "Не указан нормер контракта в cтроке " & .Row
                    Stop
                End If
                
                ' Закрыть документ
                doc.Close False
                Set doc = Nothing
            End If
                        
            ' Завершить работу с Word
            wrd.Quit False
            Set wrd = Nothing
            
            End If
        End With
    Next lr
End Sub
 
 
' Составление списка докумекнтов для СЗ на Самоцветову М.В.
Sub ListOfDoc()
    Dim contr As Long, lr As ListRow, lrRange As Range, wdt As Date, MyPath As String
    Dim MyName As String, wbk As Workbook, wsh As Worksheet, i As Long, j As Long
    
    MyPath = ThisWorkbook.Path & "\"
    wdt = Now() ' Текущая дата используется для даты выставления счетов
    i = ThisWorkbook.Worksheets("ТН").ListObjects(1).Range.Rows.Count + 3
    For contr = 500 To 700 Step 200
        For Each lr In ThisWorkbook.Worksheets("ТН").ListObjects(1).ListRows
            Set lrRange = lr.Range
            If lrRange.Cells(15) = contr Then
                If contr = 500 Then
                    MyName = "Счет 77-598_1200500-О-" & lrRange.Cells(21) & " от " & Format(wdt, "dd.mm.yyyy") & ".xlsx"
                ElseIf contr = 700 Then
                    MyName = "Счет 77-598_1110700-О-" & lrRange.Cells(21) & " от " & Format(wdt, "dd.mm.yyyy") & ".xlsx"
                End If
                Set wbk = Workbooks.Open(MyPath & MyName)
                Set wsh = wbk.Worksheets(1)
                With ThisWorkbook.Worksheets("ТН")
                    .Cells(i, 1) = wsh.Cells(3, 5) & " на 1 л. в 2 экз. (оригинал)": i = i + 1
                    .Cells(i, 1) = "'- Письмо-поручение на с" & Mid$(wsh.Cells(3, 5), 2) & " на 1 л. в 1 экз. (оригинал)": i = i + 1
                    If lrRange.Cells(5) = 0 Then
                        .Cells(i, 1) = "'- СПД на с" & Mid$(wsh.Cells(3, 5), 2) & " на 1 л. в 1 экз. (оригинал)": i = i + 1
                    End If
                    j = 49
                    Do While wsh.Cells(j, 2).Value <> Empty
                        .Cells(i, 1) = "'- " & wsh.Cells(j, 2)
                        i = i + 1
                        j = j + 1
                    Loop
                    .Cells(i, 1) = "'- " & wsh.Cells(48, 2): i = i + 2
                End With
                Set wsh = Nothing
                wbk.Close False
                Set wbk = Nothing
            End If
            Set lr = Nothing
        Next lr
    Next
End Sub

@xenohunter · 11.09.2014, 16:12 **[ТС]**

shanemac51, данные будут выглядеть примерно так:

Код

A | B    | C       | D
№ | Имя  | Фамилия | Путь к изображению
1 | Иван | Сидоров | С:\Photo\Img_1.jpg

Размер - до 1000x1000 пикселей, форматы JPG и PNG.

mc-black, спасибо большое за пример! Это, вероятней всего, именно то что нужно. Попробую вечером в нём разобраться, и, если будут вопросы, напишу ещё.

@mc-black · 11.09.2014, 16:34

В двух словах - документы .docx мне было проще не создавать с нуля, а использовать специально подготовленный шаблон, который брать за основу, я сделал шаблоны в формате .dotx. Далее, в открытом шаблоне остается автоматом заменить заранее подготовленные поля типа "%username%" на "Иван Иванович Иванов" и так далее. С точки зрения программирования это выглядит очень просто.

@xenohunter · 16.09.2014, 01:55 **[ТС]**

mc-black, сделал всё почти как в вашем примере, скрипт запускается, но не работает замена слов-переменных в шаблоне. Шаблон .dotx, всё его содержимое - строка "%username%". Код скрипта:

Visual Basic

Sub CreateDocs()
 
    Dim lr As ListRow, wbk As Workbook, dst As Worksheet
    Dim i As Integer, username As String
    Dim wrd As Object, doc As Object
 
    For i = 1 To 2 ' 1 To 10
 
        Set wrd = CreateObject("Word.Application")
        wrd.Visible = True
 
        Set doc = wrd.Documents.Add(ThisWorkbook.Path & "\test.dotx")
 
        With doc.Content.Find
            .Text = "%username%"
            .ClearFormatting
            ' .Replacement.Text = "" + Sheets("Data").Cells(i + 1, 2) + " " + Sheets("Data").Cells(i + 1, 3) + ""
            .Replacement.Text = "111"
            .Replacement.ClearFormatting
            .Execute Replace:=wdReplaceAll
        End With
 
        doc.SaveAs ThisWorkbook.Path & "\" & Sheets("Data").Cells(i + 1, 2) & " " & Sheets("Data").Cells(i + 1, 3) & ".docx"
 
        doc.Close False
        Set doc = Nothing
 
        wrd.Quit False
        Set wrd = Nothing
 
    Next i
 
End Sub

Также не получается сохранить переменную username:

Visual Basic

1 2	Dim i As Integer, username As String Set username = Sheets("Data").Cells(i + 1, 2) + " " + Sheets("Data").Cells(i + 1, 3)

shanemac51 · 16.09.2014, 07:00

Попробуйте так

Visual Basic

Dim i As Integer, username1 As String
 
'...............
username1 = Sheets("Data").Cells(i + 1, 2)  & " "  & Sheets("Data").Cells(i + 1, 3)
'..................................
.Replacement.Text = username1

@xenohunter · 16.09.2014, 10:19 **[ТС]**

shanemac51, да, без директивы Set переменная создаётся, спасибо. Replacement по-прежнему не работает.

@mc-black · 16.09.2014, 11:14

Ваш код из 7-го поста выглядит работоспособным (корректным). В шаблоне dotx точно есть кусочек текста %username%? Может написано немного иначе? Прикрепите в сообщении пример файла dotx и файла excel, запаковав из в zip (иначе не прикрепить). Без отладки на данных VBA-код как набор букв, его не выполнить, не разберешься в чем дело. Объявления лишних переменных можно убрать: Dim lr As ListRow, wbk As Workbook, dst As Worksheet

@xenohunter · 16.09.2014, 11:26 **[ТС]**

mc-black, в шаблоне точно есть строка "%username%", копировал прямо из макроса. Более того, после выполнения Selection.Find Execute Replace:=wdReplaceAll свойство Selection.Find.Found устанавливается в True, но замены не происходит. Немного поменял код, но принципиальных изменений нет, он так и не работает.

shanemac51 · 16.09.2014, 11:26

Replacement по-прежнему не работает.

а где у вас искомое поле
--может в коллонтитуле
--или в надписи

@mc-black · 16.09.2014, 11:46

В объявления надо вставить строку:

Visual Basic

1	Const wdReplaceAll = 2

Или заменить в выражении замены эту константу её значением - поставить 2.
Как выловил ошибку? Поставил в начале модуля Option Explicit, начал отладку и сразу выяснилось, что не объявлена переменная wdReplaceAll, а так как всё необъявленное инициализируется нулями, то вышло что вышло. Всем (кроме Catstail) настоятельно рекомендую использовать Option Explicit.

@xenohunter · 16.09.2014, 14:29 **[ТС]**

mc-black, спасибо! Думал, это встроенный параметр: во всех руководствах в такой форме написано.
Теперь осталось добавить изображение, сейчас буду экспериментировать.

@xenohunter · 18.09.2014, 21:41 **[ТС]**

mc-black, изображение вставляется, но не удаётся позиционировать его. Пробовал добавить изображение в коллекцию Shapes документа (wrd.Selection.Shapes.AddPicture), выпала ошибка "Run-time error '438': Object doesn't support this property or method". В коллекцию InlineShapes добавляется (wrd.Selection.InlineShapes.AddPicture), но тогда нет возможности добавить позицию и размеры изображения. Также необходимо поместить изображение "за текст", чтобы надписи не сдвигались, для этого использую метод .ConvertToShape объекта изображения; он работает. Весь актуальный код:

Visual Basic

Set pic = wrd.Selection.InlineShapes.AddPicture( _
    Filename:=ThisWorkbook.Path & "\Фото пользователей\" & user_pic, _
    LinkToFile:=False, _
    SaveWithDocument:=True _
)
pic.ConvertToShape

P.S. В официальной документации указано, что аргументы Left, Top, Width и Height можно передавать в создаваемый объект либо коллекции Shapes, либо CanvasShapes, но не InlineShapes.
P.P.S. После применения .ConvertToShape искомые свойства так и не получается изменить, выпадает ошибка "Run-time error '438': Object doesn't support this property or method", только уже по отношению к выражению pic.Left = 0.

Добавлено через 23 часа 45 минут
Решение найдено. Судя по всему, объекты в VB обладают странным, на мой взгляд, свойством. При изменении типа объекта через переменную (pic.ConvertToShape), сам объект, будучи частью коллекции, остаётся в документе, и его свойства изменяются, но вот в переменной, через которую мы воздействовали на объект, ссылка на него пропадает. Этим и объясняется то, что огромное количество методов возвращают изменённый объект. Решается проблема просто: создаём дополнительную переменную, и все необходимые операции по позиционированию проводим с ней:

Visual Basic

Dim user_pic As String, pic As Object, picShape As Object
 
Set pic = wrd.Selection.InlineShapes.AddPicture( _
    Filename:=ThisWorkbook.Path & "\Субдиректория\" & user_pic, _
    LinkToFile:=False, _
    SaveWithDocument:=True _
)
 
Set picShape = pic.ConvertToShape
picShape.LockAspectRatio = msoTrue
picShape.Left = Application.CentimetersToPoints(2.57)
picShape.Top = Application.CentimetersToPoints(3.42)
picShape.Width = Application.CentimetersToPoints(4.68)

@pashulka · 18.09.2014, 22:52

xenohunter, На самом деле, можно использовать Shapes.AddPicture и сразу указывать позицию рисунка. Нужно только вспомнить, что у Shape родитель - это документ, в примере, это doc, а не Selection

Visual Basic

1 2	doc.Shapes.AddPicture FileName:= _ ThisWorkbook.Path & "\Фото пользователей\" & user_pic, Left:=0, Top:=0

Или, если нужно обязательно мучить об'ектную переменную, то

Visual Basic

1 2	Set pic = doc.Shapes.AddPicture(Left:=0, Top:=0, _ FileName:=ThisWorkbook.Path & "\Фото пользователей\" & user_pic)

@xenohunter · 19.09.2014, 00:49 **[ТС]**

pashulka, да, этого я не знал. Пробовал только обращаться как к объекту приложения Word. Спасибо.

@xenohunter Дзен-программист 122 / 87 / 16 Регистрация: 10.04.2013 Сообщений: 253
		1
	Из файла xls/xlsx взять выбранную пользователем строку и создать документ docx 10.09.2014, 20:59. Показов 2077. Ответов 16 Метки нет (Все метки) Здравствуйте! Возник довольно примитивный вопрос, но никак не получается найти ответ. Можно ли с помощью VBA провернуть следующую схему: из файла .xls/.xlsx с некоторым количеством строк взять выбранную пользователем строку и создать документ .docx, опираясь на данные, хранящиеся в этой строке? Более того: можно ли добавить в файл .docx изображение, путь к которому хранится в одном из полей исходной строки? Заранее спасибо! 0

shanemac51 Модератор 12084 / 4944 / 791 Регистрация: 07.08.2010 Сообщений: 14,521 Записей в блоге: 4
	11.09.2014, 09:11	2
	пример в студию(пару строк с картинками) ==== кстати, какой у картинок --размер(типа иконок или солидный) 1

@mc-black 2785 / 717 / 106 Регистрация: 04.02.2011 Сообщений: 1,443
	11.09.2014, 09:41	3
	Можно. Специалисту в VBA для этого понадобится от 15 минут до пары часов времени, включая тестирование. Это при наличии полного ТЗ, исключении всех вопросов, возникающих в процессе написания, наличии файлов примеров для обработки, на которых можно произвести тестирование. На этом форуме вам помогут сделать примерно за 1-2 дня, если дадите людям файлы примеров и полное описание задачи. 1

@xenohunter Дзен-программист 122 / 87 / 16 Регистрация: 10.04.2013 Сообщений: 253
	11.09.2014, 16:12 [ТС]	5
	shanemac51, данные будут выглядеть примерно так: Код A \| B \| C \| D № \| Имя \| Фамилия \| Путь к изображению 1 \| Иван \| Сидоров \| С:\Photo\Img_1.jpg Размер - до 1000x1000 пикселей, форматы JPG и PNG. mc-black, спасибо большое за пример! Это, вероятней всего, именно то что нужно. Попробую вечером в нём разобраться, и, если будут вопросы, напишу ещё. 0

@mc-black 2785 / 717 / 106 Регистрация: 04.02.2011 Сообщений: 1,443
	11.09.2014, 16:34	6
	В двух словах - документы .docx мне было проще не создавать с нуля, а использовать специально подготовленный шаблон, который брать за основу, я сделал шаблоны в формате .dotx. Далее, в открытом шаблоне остается автоматом заменить заранее подготовленные поля типа "%username%" на "Иван Иванович Иванов" и так далее. С точки зрения программирования это выглядит очень просто. 0

@xenohunter Дзен-программист 122 / 87 / 16 Регистрация: 10.04.2013 Сообщений: 253
	16.09.2014, 10:19 [ТС]	9
	shanemac51, да, без директивы Set переменная создаётся, спасибо. Replacement по-прежнему не работает. 0

@mc-black 2785 / 717 / 106 Регистрация: 04.02.2011 Сообщений: 1,443
	16.09.2014, 11:14	10
	Ваш код из 7-го поста выглядит работоспособным (корректным). В шаблоне dotx точно есть кусочек текста %username%? Может написано немного иначе? Прикрепите в сообщении пример файла dotx и файла excel, запаковав из в zip (иначе не прикрепить). Без отладки на данных VBA-код как набор букв, его не выполнить, не разберешься в чем дело. Объявления лишних переменных можно убрать: Dim lr As ListRow, wbk As Workbook, dst As Worksheet 1

shanemac51 Модератор 12084 / 4944 / 791 Регистрация: 07.08.2010 Сообщений: 14,521 Записей в блоге: 4
	16.09.2014, 11:26	12
	Replacement по-прежнему не работает. а где у вас искомое поле --может в коллонтитуле --или в надписи 0

@xenohunter Дзен-программист 122 / 87 / 16 Регистрация: 10.04.2013 Сообщений: 253
	16.09.2014, 14:29 [ТС]	14
	mc-black, спасибо! Думал, это встроенный параметр: во всех руководствах в такой форме написано. Теперь осталось добавить изображение, сейчас буду экспериментировать. 0

@xenohunter Дзен-программист 122 / 87 / 16 Регистрация: 10.04.2013 Сообщений: 253
	19.09.2014, 00:49 [ТС]	17
	pashulka, да, этого я не знал. Пробовал только обращаться как к объекту приложения Word. Спасибо. 0