Форум программистов, компьютерный форум, киберфорум
VBA
Войти
Регистрация
Восстановить пароль
 
Рейтинг 4.85/13: Рейтинг темы: голосов - 13, средняя оценка - 4.85
1 / 1 / 0
Регистрация: 08.11.2012
Сообщений: 38
1

Создание пользовательских свойств Word из книги Excel

16.01.2014, 00:16. Просмотров 2613. Ответов 7
Метки нет (Все метки)

Доброго времени суток, замучался набивать однотипные свойства в word'e. Помогите макросом для word 2010, создающим пользовательские свойства документа word из книги info.xls, которая лежит в одной папке с word'овским документом. Свойств может быть штук 15-20. Пример прилагаю.
0
Вложения
Тип файла: doc Свойства.doc (24.0 Кб, 43 просмотров)
Тип файла: xls info.xls (27.0 Кб, 44 просмотров)
Programming
Эксперт
94731 / 64177 / 26122
Регистрация: 12.04.2006
Сообщений: 116,782
16.01.2014, 00:16
Ответы с готовыми решениями:

Подпрограмма: Вывести имена и значения всех встроенных и пользовательских свойств заданной рабочей книги...
(Exel | Word) Создайте процедуру, которая в таблицу Excel выводит имена и значения всех встроенных...

Как отключить область свойств документа в Word, Excel 2010?
При каждом открытии документа в Word, Excel 2010 выпадает окно области свойств документа. Всякий...

Перенос данных из книги Excel в Word
проблемка такая.. написал в Ворде простенький макрос для переноса данных из книги Эксель в Ворд.....

Заполнение книги Excel данными из документа Word
Добрый день. Пролистал около десятка тем на этом форуме и еще на нескольких, так и не смог найти...

7
5346 / 1411 / 331
Регистрация: 23.12.2010
Сообщений: 2,078
Записей в блоге: 1
16.01.2014, 17:58 2
Запускать из Excel при открытом файле с данными полей.
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
Sub Ex_Word_Обновить_своиства_doc_и_поля()
    Dim MyPath$, MyFile$, i&
    Dim wdApp As Object, wdDoc As Object
    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = True
    MyPath = ActiveWorkbook.path & "\"
    MyFile = Dir(MyPath & "*.doc*")
    If MyFile = "" Then
         MsgBox "Рядом с данным файлом не найден файл doc"
         Exit Sub
    End If
    MyFile = MyPath & MyFile
    Set wdDoc = wdApp.Documents.Open(MyFile)
    With ActiveWorkbook.Sheets("Штамп")
        For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).row
            wdDoc.CustomDocumentProperties(.Cells(i, 1).Value).Value = .Cells(i, 2).Value
        Next i
    End With
    For i = 1 To wdDoc.Fields.Count
        With wdDoc.Fields(i)
            If .Type = 85 Then  'wdFieldDocProperty=85
                .Update
            End If
        End With
    Next i
    wdApp.Activate
End Sub
0
1 / 1 / 0
Регистрация: 08.11.2012
Сообщений: 38
16.01.2014, 23:08  [ТС] 3
При запуске открывает первый попавшийся *.doc и пишет "Invalid procedure call or argument", если можно, сделать запуск из word, т.к. info.xls в папке один, а *.doc и *.docx несколько, с различными названиями.

Добавлено через 36 минут
При подключенной "Microsoft Excel Object Library" в word выдает тоже самое
0
5346 / 1411 / 331
Регистрация: 23.12.2010
Сообщений: 2,078
Записей в блоге: 1
17.01.2014, 10:47 4
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
Sub Word_from_Excel_Обновить_свойства_doc_и_поля()
    Dim MyPath$, MyFile$, i&
    Dim xlApp As Object, xlBook As Object
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    MyPath = ActiveDocument.Path & "\"
    MyFile = Dir(MyPath & "*.xls*")
    If MyFile = "" Then
         MsgBox "Рядом с данным файлом не найден файл xls"
         Exit Sub
    End If
    MyFile = MyPath & MyFile
    Set xlBook = xlApp.Workbooks.Open(MyFile)
    With xlBook.Sheets("Штамп")
        For i = 2 To .Cells(.Rows.Count, 1).End(-4162).Row 'xlUp= -4162
            ActiveDocument.CustomDocumentProperties(.Cells(i, 1).Value).Value = .Cells(i, 2).Value
        Next i
    End With
    For i = 1 To ActiveDocument.Fields.Count
        With ActiveDocument.Fields(i)
            If .Type = wdFieldDocProperty Then
               .Update
            End If
        End With
    Next i
    xlBook.Close 0
    xlApp.Quit
    Set xlBook = Nothing
    Set xlApp = Nothing
End Sub
0
1 / 1 / 0
Регистрация: 08.11.2012
Сообщений: 38
17.01.2014, 12:57  [ТС] 5
При запуске из Word:
открывает файл *.xls, выдает run-time error "5" invalid procedure call or argument
ругается на строку:
Visual Basic
1
ActiveDocument.CustomDocumentProperties(.Cells(i, 1).Value).Value = .Cells(i, 2).Value
не добавляет поля, а только меняет значения, если они прописаны в *.doc
0
5346 / 1411 / 331
Регистрация: 23.12.2010
Сообщений: 2,078
Записей в блоге: 1
17.01.2014, 16:20 6
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Sub Word_from_Excel_Обновить_свойства_doc_и_поля()
    Dim MyPath$, MyFile$, i&, Str1$, Str2$
    Dim xlApp As Object, xlBook As Object
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    MyPath = ActiveDocument.Path & "\"
    MyFile = Dir(MyPath & "*.xls*")
    If MyFile = "" Then
         MsgBox "Рядом с данным файлом не найден файл xls"
         Exit Sub
    End If
    MyFile = MyPath & MyFile
    Set xlBook = xlApp.Workbooks.Open(MyFile)
    With xlBook.Sheets("Штамп")
        For i = 2 To .Cells(.Rows.Count, 1).End(-4162).Row 'xlUp= -4162
            Str1 = .Cells(i, 1).Value: Str2 = .Cells(i, 2).Value
            ActiveDocument.CustomDocumentProperties(Str1).Value = Str2
        Next i
    End With
    For i = 1 To ActiveDocument.Fields.Count
        With ActiveDocument.Fields(i)
            If .Type = wdFieldDocProperty Then
               .Update
            End If
        End With
    Next i
    xlBook.Close 0
    xlApp.Quit
    Set xlBook = Nothing
    Set xlApp = Nothing
End Sub
Причина может быть в том, что количество и названия полей пользовательских свойств в книге Excel не совпадает с количеством и названиями пользовательских полей в активном документе Word. За этим надо следить.

Добавлено через 7 минут
Этот макрос создает пользовательские свойства и обновляет все поля, которые ссылаются на пользовательские свойства.
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Sub Word_from_Excel_добавить_свойства_doc()
    Dim MyPath$, MyFile$, i&, Str1$, Str2$
    Dim xlApp As Object, xlBook As Object
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    MyPath = ActiveDocument.Path & "\"
    MyFile = Dir(MyPath & "*.xls*")
    If MyFile = "" Then
         MsgBox "Рядом с данным файлом не найден файл xls"
         Exit Sub
    End If
    MyFile = MyPath & MyFile
    Set xlBook = xlApp.Workbooks.Open(MyFile)
    With xlBook.Sheets("Штамп")
        For i = 2 To .Cells(.Rows.Count, 1).End(-4162).Row 'xlUp= -4162
            Str1 = .Cells(i, 1).Value: Str2 = .Cells(i, 2).Value
            ActiveDocument.CustomDocumentProperties.Add Name:=Str1, LinkToContent:=False, Value:=Str2, Type:=msoPropertyTypeString
        Next i
    End With
    For i = 1 To ActiveDocument.Fields.Count
        With ActiveDocument.Fields(i)
            If .Type = wdFieldDocProperty Then
               .Update
            End If
        End With
    Next i
    xlBook.Close 0
    xlApp.Quit
    Set xlBook = Nothing
    Set xlApp = Nothing
End Sub
Однако если поле уже существовало ранее, то это вызовет ошибку.

Добавлено через 5 минут
И обновляет свойства, и добавляет, если они не существовали:
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
Sub Word_from_Excel_Обновить_либо_добавить_свойства_doc()
    Dim MyPath$, MyFile$, i&, Str1$, Str2$
    Dim xlApp As Object, xlBook As Object
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    MyPath = ActiveDocument.Path & "\"
    MyFile = Dir(MyPath & "*.xls*")
    If MyFile = "" Then
         MsgBox "Рядом с данным файлом не найден файл xls"
         Exit Sub
    End If
    MyFile = MyPath & MyFile
    Set xlBook = xlApp.Workbooks.Open(MyFile)
    On Error Resume Next
    With xlBook.Sheets("Штамп")
        For i = 2 To .Cells(.Rows.Count, 1).End(-4162).Row 'xlUp= -4162
            Str1 = .Cells(i, 1).Value: Str2 = .Cells(i, 2).Value
            ActiveDocument.CustomDocumentProperties(Str1).Value = Str2
            ActiveDocument.CustomDocumentProperties.Add Name:=Str1, LinkToContent:=False, Value:=Str2, Type:=msoPropertyTypeString
        Next i
    End With
    On Error GoTo 0
    For i = 1 To ActiveDocument.Fields.Count
        With ActiveDocument.Fields(i)
            If .Type = wdFieldDocProperty Then
               .Update
            End If
        End With
    Next i
    xlBook.Close 0
    xlApp.Quit
    Set xlBook = Nothing
    Set xlApp = Nothing
End Sub
2
1 / 1 / 0
Регистрация: 08.11.2012
Сообщений: 38
17.01.2014, 16:48  [ТС] 7
Последний самое то, спасибо. Если не сложно можно дописать вариант удаления существующих свойств перед добавлением новых?
0
5346 / 1411 / 331
Регистрация: 23.12.2010
Сообщений: 2,078
Записей в блоге: 1
20.01.2014, 10:30 8
Удаляет все старые пользовательские свойства и создает новые из файла Excel:
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
Sub Word_from_Excel_удалить_старые_и_добавить_новые_свойства_doc()
    Dim MyPath$, MyFile$, i&, Str1$, Str2$, El
    Dim xlApp As Object, xlBook As Object
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    MyPath = ActiveDocument.Path & "\"
    MyFile = Dir(MyPath & "*.xls*")
    If MyFile = "" Then
         MsgBox "Рядом с данным файлом не найден файл xls"
         Exit Sub
    End If
    MyFile = MyPath & MyFile
    Set xlBook = xlApp.Workbooks.Open(MyFile)
    For Each El In ActiveDocument.CustomDocumentProperties
        El.Delete
    Next
    With xlBook.Sheets("Штамп")
        For i = 2 To .Cells(.Rows.Count, 1).End(-4162).Row 'xlUp= -4162
            Str1 = .Cells(i, 1).Value: Str2 = .Cells(i, 2).Value
            ActiveDocument.CustomDocumentProperties.Add Name:=Str1, LinkToContent:=False, Value:=Str2, Type:=msoPropertyTypeString
        Next i
    End With
    For i = 1 To ActiveDocument.Fields.Count
        With ActiveDocument.Fields(i)
            If .Type = wdFieldDocProperty Then
               .Update
            End If
        End With
    Next i
    xlBook.Close 0
    xlApp.Quit
    Set xlBook = Nothing
    Set xlApp = Nothing
End Sub
1
IT_Exp
Эксперт
87844 / 49110 / 22898
Регистрация: 17.06.2006
Сообщений: 92,604
20.01.2014, 10:30

Заказываю контрольные, курсовые, дипломные и любые другие студенческие работы здесь.

Создание книги excel
Не могу найти ошибку using System; using System.Collections.Generic; using...

Создание новой книги в Excel и назначение там макросов
Всем привет! Помогите плиз, не могу справится с одной проблемой. Есть VB код содержащийся в...

создание электронной книги относительная и абсолютная адресации в ms excel
создание электронной книги относительная и абсолютная адресации в ms excel...

Создание документа Word из Excel
Доброго времени суток. есть макрос в excele надо создать документ ворд заполнить его по шаблону...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
8
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2021, vBulletin Solutions, Inc.