1

Тема: Таблицы Word и Exel

Обсуждаем проблемы связи

2

Re: Таблицы Word и Exel

Для нормальной связи Таблицы Excel в Worde достаточно использовать 2-е функции

Public Function SelRng(xlRng As Excel.Range) As Excel.Range
    xlRng.Select
    Set SelRng = xlWBook.Application.Selection
End Function

Public Function xlTableCells(xlRng As Excel.Range) As Collection
Dim xlTableRng As Excel.Range
Dim xlSelCell As Excel.Range
Dim Cell As Collection, MergeCells As Collection
Dim rwCount As Long, clCount As Long, r As Long, c As Long
Dim NameMerge As String, i As Long, mr As Long, mc As Long
    Set xlTableRng = xlRng
        rwCount = xlTableRng.Rows.Count
        clCount = xlTableRng.Columns.Count
        Set xlTableCells = New Collection
            With xlTableCells
                .Add rwCount, "rwCount"
                .Add clCount, "clCount"
            End With
        NameMerge = ""
            For r = 1 To rwCount
                For c = 1 To clCount
                    Set xlSelCell = SelRng(xlTableRng.Cells(r, c))
                        If InStr(1, NameMerge, xlSelCell.Address(, , xlR1C1)) = 0 Then
                            i = i + 1
                            NameMerge = NameMerge & xlSelCell.Address(, , xlR1C1)
                                Set Cell = New Collection
                                Set MergeCells = New Collection
                                    With Cell
                                        .Add xlSelCell, "Cell"
                                        .Add xlSelCell.Address(, , xlR1C1)
                                        .Add xlSelCell.Style, "Style"
                                        .Add xlSelCell.Value, "Value"
                                        .Add xlSelCell.Text, "Text"
                                        .Add MergeCells, "MergeCells"
                                            If xlSelCell.MergeCells = True Then
                                                For mr = 1 To xlSelCell.Rows.Count
                                                    For mc = 1 To xlSelCell.Columns.Count
                                                        If mr > 1 Or mc > 1 Then
                                                            NameMerge = NameMerge & xlSelCell.Cells(mr, mc).Address(, , xlR1C1)
                                                        End If
                                                    Next mc
                                                Next mr
                                                mr = xlSelCell.Rows.Count - 1
                                                mc = xlSelCell.Columns.Count - 1
                                                    With MergeCells
                                                        .Add mr, "mr"
                                                        .Add mc, "mc"
                                                    End With
                                                c = c + mc
                                                    
                                            End If
                                    End With
                                xlTableCells.Add Cell, "Cell_" & i
                        End If
                Next c
            Next r
End Function

3

Re: Таблицы Word и Exel

где их (находясь в Ворде, Экселе) и как запускать?

4

Re: Таблицы Word и Exel

Обе функции должны быть на стороне Word?

Удобной и приятной работы в Word!
Перевести спасибо на Яндекс кошелёк - 41001162202962; на WebMoney - R581830807057.

5

Re: Таблицы Word и Exel

Обе функции применяются на стороне Ворда.
Я создал в Ворде класс clsTableExcel вот его код

Public WithEvents xlApp As Excel.Application
Public WithEvents xlWBook As Excel.Workbook
Public WithEvents xlWSheet As Excel.Worksheet

Public Function SelRng(xlRng As Excel.Range) As Excel.Range
    xlRng.Select
    Set SelRng = xlWBook.Application.Selection
End Function

Public Function xlTableCells(xlRng As Excel.Range) As Collection
Dim xlTableRng As Excel.Range
Dim xlSelCell As Excel.Range
Dim Cell As Collection, MergeCells As Collection
Dim rwCount As Long, clCount As Long, r As Long, c As Long
Dim NameMerge As String, i As Long, mr As Long, mc As Long
    Set xlTableRng = xlRng
        rwCount = xlTableRng.Rows.Count
        clCount = xlTableRng.Columns.Count
        Set xlTableCells = New Collection
            With xlTableCells
                .Add rwCount, "rwCount"
                .Add clCount, "clCount"
            End With
        NameMerge = ""
            For r = 1 To rwCount
                For c = 1 To clCount
                    Set xlSelCell = SelRng(xlTableRng.Cells(r, c))
                        If InStr(1, NameMerge, xlSelCell.Address(, , xlR1C1)) = 0 Then
                            i = i + 1
                            NameMerge = NameMerge & xlSelCell.Address(, , xlR1C1)
                                Set Cell = New Collection
                                Set MergeCells = New Collection
                                    With Cell
                                        .Add xlSelCell, "Cell"
                                        .Add xlSelCell.Address(, , xlR1C1)
                                        .Add xlSelCell.Style, "Style"
                                        .Add xlSelCell.Value, "Value"
                                        .Add xlSelCell.Text, "Text"
                                        .Add MergeCells, "MergeCells"
                                            If xlSelCell.MergeCells = True Then
                                                For mr = 1 To xlSelCell.Rows.Count
                                                    For mc = 1 To xlSelCell.Columns.Count
                                                        If mr > 1 Or mc > 1 Then
                                                            NameMerge = NameMerge & xlSelCell.Cells(mr, mc).Address(, , xlR1C1)
                                                        End If
                                                    Next mc
                                                Next mr
                                                mr = xlSelCell.Rows.Count - 1
                                                mc = xlSelCell.Columns.Count - 1
                                                    With MergeCells
                                                        .Add mr, "mr"
                                                        .Add mc, "mc"
                                                    End With
                                                c = c + mc
                                                    
                                            End If
                                    End With
                                xlTableCells.Add Cell, "Cell_" & i
                        End If
                Next c
            Next r
End Function

Здесь соответственно 
Public WithEvents xlApp As Excel.Application
Public WithEvents xlWBook As Excel.Workbook
Public WithEvents xlWSheet As Excel.Worksheet

основные объекты экселя
Приложение
Рабочая книга
Рабочий лист

Public WithEvents дает возможность использовать события этих объектов
Вот тестирующий код

Public Sub Test()
Dim cls As clsTableExcel
Dim TableCells As Collection
    Set cls = New clsTableExcel
        With cls
            Set .xlApp = New Excel.Application
            Set .xlWBook = .xlApp.Workbooks.Add
            .xlApp.Visible = True
            .xlWBook.Activate
        End With
        Set TableCells = cls.xlTableCells(cls.xlWBook.Application.Selection)
            ActiveDocument.Tables.Add Selection.Range, TableCells("rwCount"), TableCells("clCount")
        cls.xlApp.Quit
End Sub

Где
Dim cls As clsTableExcel
Dim TableCells As Collection

cls созданный нами класс

clsTableExcel
TableCells

является коллекцией ячеек таблицы которые мы хотим связать
Код
       

With cls
            Set .xlApp = New Excel.Application
            Set .xlWBook = .xlApp.Workbooks.Add
            .xlApp.Visible = True
            .xlWBook.Activate
        End With

говорит Ворду
1. Создай новое приложение Эксель
2. Создай новую рабочую книгу в этом приложении
3. Сделай данное приложение видимым
4. Сделай рабочую книгу активной
Далее идет строка

Set TableCells = cls.xlTableCells(cls.xlWBook.Application.Selection)

она говорит
Присвоить переменной TableCells функцию cls.xlTableCells(cls.xlWBook.Application.Selection)
Где
cls.xlWBook.Application.Selection являются выделенными ячейками Экселя,  которые мы хотим преобразовать и связать как таблицу Ворд
Далее пойдет описание действий функций
xlTableCells и SelRng

6

Re: Таблицы Word и Exel

Небольшое отступление…1
Ручное связывание Ворда и Экселя.
При выполнении этого действия мы должны:
1. Выделить ячейку, либо диапазон ячеек
2. Добавить их в Буфер обмена путем Копировния
3. В Ворде установить курсор в то место, где будут находиться данные Экселя
4. Далее Правка-->Специальная вставка и выбираем нужный нам параметр
Связь Экселя и Ворда произошла
Теперь рассмотрим алгоритм создания таблицы Ворд, на основе таблицы Эксель

7

Re: Таблицы Word и Exel

aap77 пишет:

Обе функции применяются на стороне Ворда.
Я создал в Ворде класс clsTableExcel вот его код

Было бы очень интересно посмотреть работу этого механизма на практике, в виде файлов.

Удобной и приятной работы в Word!
Перевести спасибо на Яндекс кошелёк - 41001162202962; на WebMoney - R581830807057.

8

Re: Таблицы Word и Exel

Alex_Gur пишет:
aap77 пишет:

Обе функции применяются на стороне Ворда.
Я создал в Ворде класс clsTableExcel вот его код

Было бы очень интересно посмотреть работу этого механизма на практике, в виде файлов.

Куда уж практичней функция xlTableCells собирает все нужные данные для передачи в Ворд

9

Re: Таблицы Word и Exel

Вот текст функции xlTableCells с кратким описанием используемых в ней переменных:

Public Function xlTableCells(xlRng As Excel.Range) As Collection
Dim xlTableRng As Excel.Range ' Общий диапазон таблицы
Dim xlSelCell As Excel.Range ' Отдельная ячейка диапазона таблицы
Dim Cell As Collection ' Коллекция, представляющая отдельную ячеку,
' которая содержит все нужные данные и будет связана с таблицей Word
Dim MergeCells As Collection ' Коллекция входящая в коллекцию Cell и содержащая данные
' данные о количестве объединенных ячеек по горизонтали и вертикали.
' В последствии данные этой коллекции помогут корректно объединить ячейки в таблице Word
Dim rwCount As Long, clCount As Long ' Количество ячеек по горизонтали и вертикали
' в таблице Excel которую надо импортировать
Dim r As Long, c As Long ' Отдельный адрес строки и столбца в таблице Excel которую надо импортировать
Dim NameMerge As String ' Общий список уже просмотренных ячеек в таблице Excel
Dim mr As Long, mc As Long ' Данные для коллекции MergeCells
    Set xlTableRng = xlRng
        rwCount = xlTableRng.Rows.Count
        clCount = xlTableRng.Columns.Count
        Set xlTableCells = New Collection
            With xlTableCells
                .Add rwCount, "rwCount"
                .Add clCount, "clCount"
            End With
        NameMerge = ""
            For r = 1 To rwCount
                For c = 1 To clCount
                    Set xlSelCell = SelRng(xlTableRng.Cells(r, c))
                        If InStr(1, NameMerge, xlSelCell.Address(, , xlR1C1)) = 0 Then
                            NameMerge = NameMerge & xlSelCell.Address(, , xlR1C1)
                                Set Cell = New Collection
                                i = i + 1
                                Set MergeCells = New Collection
                                    With Cell
                                        .Add xlSelCell, "Cell"
                                        .Add xlSelCell.Address(, , xlR1C1)
                                        .Add xlSelCell.Style, "Style"
                                        .Add xlSelCell.Value, "Value"
                                        .Add xlSelCell.Text, "Text"
                                        .Add MergeCells, "MergeCells"
                                            If xlSelCell.MergeCells = True Then
                                                For mr = 1 To xlSelCell.Rows.Count
                                                    For mc = 1 To xlSelCell.Columns.Count
                                                        If mr > 1 Or mc > 1 Then
                                                            NameMerge = NameMerge & xlSelCell.Cells(mr, mc).Address(, , xlR1C1)
                                                        End If
                                                    Next mc
                                                Next mr
                                                mr = xlSelCell.Rows.Count - 1
                                                mc = xlSelCell.Columns.Count - 1
                                                    With MergeCells
                                                        .Add mr, "mr"
                                                        .Add mc, "mc"
                                                    End With
                                                c = c + mc
                                                    
                                            End If
                                    End With
                                xlTableCells.Add Cell, "Cell_" & i
                        End If
                Next c
            Next r
End Function

Далее рассмотрим подробнее действия этого кода