Форум программистов, компьютерный форум, киберфорум
MS Office Word
Войти
Регистрация
Восстановить пароль
 
Рейтинг 4.98/49: Рейтинг темы: голосов - 49, средняя оценка - 4.98
Outaveli
0 / 0 / 0
Регистрация: 27.10.2012
Сообщений: 22
1

Как разделить таблицу с уже готовым в ней текстом на столбцы

08.11.2012, 15:08. Просмотров 9912. Ответов 9
Метки нет (Все метки)

Ребята, есть текст
Вложение 1.

Который нужно преобразовать в таблицу с 4-мя столбцами, сначала преобразую в таблицу с 1-м столбцом
Вложение 2.

Далее рисую разделители в ворде (от руки).
Вложение 3.

Проблема.. если рисуешь разделители от руки, то нельзя нарисовать больше, чем на одну страницу.. дальше просто курсор не идет, а таблица огромная.

Вопрос. как можно разделить эту таблицу на столбцы, не прибегая к ''ручному'' методу? может есть какой то макрос для преобразования текста в таблицу уже со столбцами? потому что если преобразовывать стандартной функцией в ворде весь текст путается в получившихся ячейках.
0
Миниатюры
Как разделить таблицу с уже готовым в ней текстом на столбцы   Как разделить таблицу с уже готовым в ней текстом на столбцы   Как разделить таблицу с уже готовым в ней текстом на столбцы  

QA
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
08.11.2012, 15:08
Ответы с готовыми решениями:

Разделить сводную таблицу / пустые столбцы сводной таблицы
Доброго времени суток, форумчане! Столкнулся на работе с проблемой при формировании сводной...


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

Или воспользуйтесь поиском по форуму:
9
Скрипт
5454 / 1135 / 49
Регистрация: 15.09.2012
Сообщений: 3,433
08.11.2012, 15:33 2
Outaveli, выложите файл Word, содержащий фрагмент из первого скрин-шота (сообщение #1), чтобы попробовать макрос написать.
0
aap77
440 / 33 / 4
Регистрация: 12.09.2011
Сообщений: 109
08.11.2012, 15:50 3
Быстрого варианта Вашей проблемы нет. Макрос можно написать, но нужно несколько страниц для тестирования и время.
0
Outaveli
0 / 0 / 0
Регистрация: 27.10.2012
Сообщений: 22
08.11.2012, 16:47  [ТС] 4
Прикрепил к сообщению, благодарен за помощь!
0
Вложения
Тип файла: docx Фрагмент.docx (14.8 Кб, 55 просмотров)
Скрипт
5454 / 1135 / 49
Регистрация: 15.09.2012
Сообщений: 3,433
08.11.2012, 20:09 5
Outaveli, код написан под файл, выложенный в сообщении #4.
Запускать нужно процедуру Main.
После работы коды, нужно выделить весь документ и превратить текст в таблицу. Должно быть 4 столбца. Если будет не 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
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
Sub Main()
 
    'Отключаем обновление монитора, чтобы было быстрее.
    Application.ScreenUpdating = False
    
    '1. Действие по определению начало строки.
    With ActiveDocument.Range.Find
        .Text = "(^0013)(  )([0-9])"
        .Replacement.Text = "\1\3"
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With
    
    '2. Два и более пробела меняем на один знак табуляции.
        'Символ табуляции будет служить для создания столбцов в таблице.
    With ActiveDocument.Range.Find
        .Text = " {2;}"
        .Replacement.Text = "^t"
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With
 
    '3. Удаляем знак табулции в самом первом абзаце.
    If ActiveDocument.Paragraphs(1).Range.Characters(1).Text = Chr(9) Then
        ActiveDocument.Paragraphs(1).Range.Characters(1).Delete
    End If
    
    '4. Формирование третьего столбца.
    Call Procedure_1
    
    '5. Знак абзац, знак табуляции и число заменяем на число и пробел.
        'Это формирование последнего столбца в таблице.
    With ActiveDocument.Range.Find
        .Text = "(^0013^t)([0-9])"
        .Replacement.Text = " \2"
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With
    
    '6. Формирование третьего столбца.
    Call Procedure_2
    
    '7. Удаление в конце документа пустого абзаца.
    If ActiveDocument.Paragraphs.Last.Range.Text = Chr(13) Then
         ActiveDocument.Paragraphs.Last.Range.Delete
    End If
 
    MsgBox "Работа кода завершена!", vbInformation
 
    'Включаем обновление монитора.
    Application.ScreenUpdating = True
    
 
End Sub
 
Sub Procedure_1()
 
    Dim oParagraph As Word.Paragraph
    Dim vArray_1 As Variant, vArray_2 As Variant
    Dim i As Long, j As Long
    
    'Просматриваем все абзацы в документе.
    For i = 1 To ActiveDocument.Paragraphs.Count Step 1
        
        Set oParagraph = ActiveDocument.Paragraphs(i)
    
        'Если абзац начинается со знака табуляции и в абзаце 2 знака табуляции.
        If Asc(Left(oParagraph.Range.Text, 1)) = 9 Then
        
            vArray_1 = Split(oParagraph.Range.Text, Chr(9))
            
            If UBound(vArray_1) > 1 Then
            
                'Удаляю из абзаца знак табуляции и текст.
                oParagraph.Range.Text = _
                    Mid(oParagraph, Len(vArray_1(1)) + 2)
                
                'Идём вверх по абзацам и ищем абзац, который начинается числом.
                j = 1
                Do
                    oParagraph.Previous(j).Range.Select
                    If Left(oParagraph.Previous(j).Range.Text, 1) Like "[0-9]" Then
                        vArray_2 = Split(oParagraph.Previous(j).Range.Text, Chr(9))
                        Exit Do
                    End If
                    j = j + 1
                Loop
                
                'Изменяю третий столбец в абзаце выше.
                vArray_2(2) = vArray_2(2) & " " & vArray_1(1)
                oParagraph.Previous(j).Range.Text = Join(vArray_2, Chr(9))
                
            End If
            
        End If
        
    Next i
    
End Sub
 
Sub Procedure_2()
 
    Dim rFindRange As Word.Range, lStart As Long
    Dim vArray As Variant
    Dim sParagraph_2 As String
 
    'Указываем диапазон документа, где вести поиск.
    Set rFindRange = ActiveDocument.Range
 
    Do
    
        With rFindRange.Find
            
            'Ищу знак абзаца, знак табуляции, любые символы, знак абзаца.
            'Это фрагмент для 3 столбца таблицы.
            .Text = "^0013^t*^0013"
            .MatchWildcards = True
            
            'Останавливаем поиск, если в заданном диапазоне не найдено.
            .Wrap = wdFindStop
            
            If .Execute = True Then
                
                'Найденный фрагмент содержит 2 абзаца:
                'от первого абзаца только знак абзаца, остальное - второй абзац.
                
                'Запоминаем начало первого абзаца, чтобы с него
                'продолжить поиск.
                lStart = .Parent.Paragraphs(1).Range.Start
                
                'Помещаю содержимое первого абзаца в массив.
                'Chr(9) - это знак табуляции.
                vArray = Split(.Parent.Paragraphs(1).Range.Text, Chr(9))
                
                'Содержимое второго абзаца помещаю в переменную (для удобства написания кода).
                sParagraph_2 = .Parent.Paragraphs(2).Range.Text
                
                'Элементы массива нумеруются с нуля.
                'В третий элемент массива помещаю текст из второго абзаца
                'без знака табуляции и знака абзаца и добавляю пробел.
                
                'Есть 2 вариант с 3 столбцом:
                    '1. Вариант - столбец заканчивается знаком абзаца;
                    '2. Вариант - после 3 столбца есть 4 столбец.
                'Надо это учитывать.
                If Asc(Right(vArray(2), 1)) = 13 Then
                    vArray(2) = Left(vArray(2), Len(vArray(2)) - 1) & " " & _
                        Mid(sParagraph_2, 2, Len(sParagraph_2) - 2) & Chr(13)
                Else
                    vArray(2) = vArray(2) & " " & Mid(sParagraph_2, 2, Len(sParagraph_2) - 2)
                End If
                
                'Формируем первый абзац с изменениями.
                .Parent.Paragraphs(1).Range.Text = Join(vArray, Chr(9))
                
                'Удаляем второй абзац.
                .Parent.Paragraphs(2).Range.Delete
                
                'Сужаем диапазон для поиска.
                Set rFindRange = _
                    ActiveDocument.Range(Start:=lStart, End:=ActiveDocument.Range.End)
                
            'Если не находится больше, значит надо остановить поиск.
            Else
                
                Exit Do
                
            End If
            
        End With
    
    Loop
    
End Sub
1
Outaveli
0 / 0 / 0
Регистрация: 27.10.2012
Сообщений: 22
08.11.2012, 23:30  [ТС] 6
Скрипт, спасибо Вам огромное за работу, но есть одна проблемка.. далее в таблице следует немного другого формата текст, то есть в общем там 2 формата - тот который я присылал и тот, который в этом сообщении.. и текст таким образом путается, если Вам не сложно, не могли бы Вы доработать Вашу формулу
Скрин-шот 1 - исходника

Скрин-шот 2 - после применения Вашего макроса

Вложение 3 - фрагмент текста другого формата
0
Миниатюры
Как разделить таблицу с уже готовым в ней текстом на столбцы   Как разделить таблицу с уже готовым в ней текстом на столбцы  
Вложения
Тип файла: docx Фрагмент2.docx (30.5 Кб, 8 просмотров)
Outaveli
0 / 0 / 0
Регистрация: 27.10.2012
Сообщений: 22
09.11.2012, 00:17  [ТС] 7
есть ещё один фрагмент
0
Вложения
Тип файла: docx Фрагмент3.docx (15.7 Кб, 10 просмотров)
Outaveli
0 / 0 / 0
Регистрация: 27.10.2012
Сообщений: 22
09.11.2012, 02:21  [ТС] 8
Наверно, нужно было сразу вложить весь документ(извиняюсь за сей тупизм с моей стороны, он весит больше, чем позволяют рамки форума.
весь документ можно скачать [ссылка удалена]

извиняюсь ещё раз.
 Комментарий модератора 
Картинки и файлы прикладывайте к сообщению. Большие файлы архивируйте. Размер файлов .RAR, .ZIP, .7Z до 10 МБ!
0
Вложения
Тип файла: rar 10-20.rar (305.4 Кб, 6 просмотров)
Скрипт
5454 / 1135 / 49
Регистрация: 15.09.2012
Сообщений: 3,433
09.11.2012, 12:57 9
Outaveli, код написан под файл, ссылка на который в сообщении #8.
Запускать нужно процедуру Main.
После работы коды, нужно выделить весь документ и превратить текст в таблицу. Должно быть 4 столбца. Если будет не 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
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
Sub Main()
 
    'Отключаем обновление монитора, чтобы было быстрее.
    Application.ScreenUpdating = False
    
    '1. Удаление двух и более пустых абзацев.
    With ActiveDocument.Content.Find
        .Text = "^0013{2;}"
        .Replacement.Text = "^p"
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With
    
    '2. Добавляем в конец документа пустой абзац, без
        'которго в одном месте кода может быть ошибка.
    ActiveDocument.Content.InsertParagraphAfter
    
    '3. Действие по определению начала строки.
        'В начале некоторых строк есть 2 пробела.
        'Удалим эти 2 пробела и тогда строка будет начинаться числом.
        'А все остальные строки будут начинаться знаком табуляции.
    With ActiveDocument.Range.Find
        .Text = "(^0013)(  )([0-9])"
        .Replacement.Text = "\1\3"
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With
    
    '4. Знак абзаца, 51 знак пробела меняем на знак абзаца и 2 знака табулции.
        'Это будет означать, что строка относится к четвёртому столбцу.
    With ActiveDocument.Content.Find
        .Text = "(^0013)( ){51}"
        .Replacement.Text = "\1^t^t"
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With
    
    '5. Два и более пробела меняем на один знак табуляции.
        'Символ табуляции будет служить для создания столбцов в таблице.
    With ActiveDocument.Range.Find
        .Text = " {2;}"
        .Replacement.Text = "^t"
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With
 
    '6. Удаляем знак табуляции в самом первом абзаце.
    If ActiveDocument.Paragraphs(1).Range.Characters(1).Text = Chr(9) Then
        ActiveDocument.Paragraphs(1).Range.Characters(1).Delete
    End If
    
    '7. Формирование третьего столбца.
    Call Procedure_1
    Call Procedure_2
    
    '8. Формирование четвёртого столбца.
        'Знак абзаца и два знака табуляции заменяем на пробел.
    With ActiveDocument.Range.Find
        .Text = "^0013^t^t"
        .Replacement.Text = " "
        .Execute Replace:=wdReplaceAll
    End With
    
    '9. Удаление в конце документа пустого абзаца.
    Do While ActiveDocument.Paragraphs.Last.Range.Text = Chr(13)
         ActiveDocument.Paragraphs.Last.Range.Delete
    Loop
 
    MsgBox "Работа кода завершена!", vbInformation
 
    'Включаем обновление монитора.
    Application.ScreenUpdating = True
    
 
End Sub
 
Sub Procedure_1()
 
    'Обработка строк, которые содержат только фрагмент третьего столбца.
    
    Dim rFindRange As Word.Range, lStart As Long
    Dim vArray_1 As Variant, vArray_2 As Variant
 
    'Указываем диапазон документа, где вести поиск.
    Set rFindRange = ActiveDocument.Range
 
    Do
    
        With rFindRange.Find
            
            'Ищу знак абзаца, знак табуляции.
            '[!^t] - чтобы не находить
            .Text = "^0013^t[!^t]"
            .MatchWildcards = True
            
            If .Execute = True Then
            
                'Найденный фрагмент содержит 2 абзаца:
                'от первого абзаца только знак абзаца, остальное - второй абзац.
                
                'Помещаю содержимое первого и второго абзаца в массив.
                'Chr(9) - это знак табуляции.
                vArray_1 = Split(.Parent.Paragraphs(1).Range.Text, Chr(9))
                vArray_2 = Split(.Parent.Paragraphs(2).Range.Text, Chr(9))
                
                'Элементы массива нумеруются с нуля.
                'В vArray_1 может быть 3 и 4 элемента. Работаем только с 3 элементом.
                'В vArray_2 может быть 2 и 3 элемента. Работаем только со 2 элементом.
                
                'Если в vArray_2 2 элемента
                '(т.е. содержится только фрагмент третьего столбца).
                If UBound(vArray_2) = 1 Then
                
                    'Запоминаем, откуда дальше продолжить поиск.
                    lStart = .Parent.Paragraphs(1).Range.Start
                
                    'В третий элемент массива vArray_1 помещаю текст из второго абзаца
                    'без знака табуляции и знака абзаца и добавляю пробел.
                    
                    'Есть 2 варианта с 3 столбцом в первом абзаце:
                        '1-й вариант - столбец заканчивается знаком абзаца;
                        '2-й вариант - после 3 столбца есть 4 столбец.
                        'Надо это учитывать.
                    If Asc(Right(vArray_1(2), 1)) = 13 Then
                        vArray_1(2) = Left(vArray_1(2), Len(vArray_1(2)) - 1) & " " & _
                            Left(vArray_2(1), Len(vArray_2(1)) - 1) & Chr(13)
                    Else
                        vArray_1(2) = vArray_1(2) & " " & Left(vArray_2(1), Len(vArray_2(1)) - 1)
                    End If
                    
                    'Формируем первый абзац с изменениями.
                    .Parent.Paragraphs(1).Range.Text = Join(vArray_1, Chr(9))
                    
                    'Удаляем второй абзац.
                    .Parent.Paragraphs(2).Range.Delete
                
                    'Сужаем диапазон для поиска.
                    Set rFindRange = _
                        ActiveDocument.Range(Start:=lStart, End:=ActiveDocument.Range.End)
                    
                Else
                
                    'Запоминаем, откуда дальше продолжить поиск.
                    lStart = .Parent.Paragraphs(2).Range.Start
                
                    'Сужаем диапазон для поиска.
                    Set rFindRange = _
                        ActiveDocument.Range(Start:=lStart, End:=ActiveDocument.Range.End)
                    
                End If
                
            'Если не находится больше, значит надо остановить поиск.
            Else
                
                Exit Do
                
            End If
            
        End With
    
    Loop
    
End Sub
 
Sub Procedure_2()
 
    'Обработка строк, которые содержат фрагменты третьего и четвёртого столбцов.
    
    Dim rFindRange As Word.Range, lStart As Long
    Dim vArray_1 As Variant, vArray_2 As Variant
    Dim oParagraph As Word.Paragraph
    Dim i As Long
 
    'Указываем диапазон документа, где вести поиск.
    Set rFindRange = ActiveDocument.Range
 
    Do
    
        With rFindRange.Find
            
            'Ищу знак абзаца, знак табуляции.
            .Text = "^0013^t[!^t]"
            .MatchWildcards = True
            
            'Останавливаем поиск, если в заданном диапазоне не найдено,
            'чтобы поиск не продолжался в оставшейся части документа.
            .Wrap = wdFindStop
            
            If .Execute = True Then
            
                'Помещаю содержимое первого абзаца в массив.
                'Chr(9) - это знак табуляции.
                vArray_1 = Split(.Parent.Paragraphs(1).Range.Text, Chr(9))
                
                'Смотрим нижние абзацы. Если в них есть в начале знак табуляции,
                'то анализируем эти абзацы.
                
                i = 1
                
                Do
                
                    'Обращаться к абзацу, у которого в начале знак табуляции,
                    'будем через переменную.
                    Set oParagraph = .Parent.Paragraphs(1).Next(i)
                    
                    vArray_2 = Split(oParagraph.Range.Text, Chr(9))
                    
                    'Если первый символ в нижнем абзаце не знак табуляции.
                    'И если вообще нет знака табулции.
                    If oParagraph.Range.Characters(1).Text <> Chr(9) Or UBound(vArray_2) = 0 Then
                        Exit Do
                    'Если во втором элементе vArray_2 пусто, значит нам
                    'этот абзац сейчас не нужен.
                    ElseIf vArray_2(1) = "" Then
                        Exit Do
                    End If
                    
                    'В третий элемент массива vArray_1 помещаю текст из второго элемента
                    'массива vArray_2 и добавляю пробел.
                    If Asc(Right(vArray_1(2), 1)) = 13 Then
                        vArray_1(2) = Left(vArray_1(2), Len(vArray_1(2)) - 1) & " " & _
                            vArray_2(1) & Chr(13)
                    Else
                        vArray_1(2) = vArray_1(2) & " " & vArray_2(1)
                    End If
                
                    'Удаляем элемент третьего столбца.
                    oParagraph.Range.Text = _
                        Chr(9) & Mid(oParagraph.Range.Text, Len(vArray_2(1)) + 2)
                
                    i = i + 1
                    
                Loop
                
                'Формируем первый абзац с изменениями.
                .Parent.Paragraphs(1).Range.Text = Join(vArray_1, Chr(9))
                
                'Откуда продолжить поиск.
                lStart = oParagraph.Range.Start
                
                'Сужаем диапазон для поиска.
                Set rFindRange = _
                    ActiveDocument.Range(Start:=lStart, End:=ActiveDocument.Range.End)
                
            'Если не находится больше, значит надо остановить поиск.
            Else
                
                Exit Do
                
            End If
            
        End With
    
    Loop
    
End Sub
0
Outaveli
0 / 0 / 0
Регистрация: 27.10.2012
Сообщений: 22
13.11.2012, 21:53  [ТС] 10
спасибо большое, очень помогло
0
13.11.2012, 21:53
Ответ Создать тему
Опции темы

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