Таблицы перенести из Writer в Calc

[Hasim]

Добрый день!
Появилась вот такая задача.
Нужно из Writer перенести содержимое таблиц в Calc.
Желательно макросом (одним нажатием кнопки).
Образцы прилагаю.
Что-то не могу сообразить, как попроще сделать.



[вложение удалено Администратором]

[JohnSUN]

Как-то так, наверное:

Код Выделить Развернуть

Sub copyTables
REM Текстовый документ и его таблицы
Dim tDoc As Variant
Dim oTextTables As Variant
Dim nCount As Long
Dim oTable As Variant
Dim oDataArray As Variant
REM Электронная таблица - первый лист
Dim cDoc As Variant
Dim oSheets As Variant
Dim oSheet As Variant
Dim nEndRow As Long
Dim oCellRangeByPosition As Variant
Dim i%, j%, k&
tDoc = ThisComponent
oTextTables = tDoc.getTextTables()
nCount = oTextTables.getCount()-1
If nCount < 0 Then Exit Sub
cDoc = StarDesktop.LoadComponentFromUrl("private:factory/scalc", "_blank", 0, Array())
oSheets = cDoc.getSheets()
oSheet = oSheets.getByIndex(0)
nEndRow = 0
For i = 0 to nCount
oTable = oTextTables.getByIndex(i)
oDataArray = oTable.getDataArray()
DelFirstRow(oDataArray)
j = nEndRow+UBound(oDataArray)
k = UBound(oDataArray(0))
oCellRangeByPosition = oSheet.getCellRangeByPosition(0, nEndRow, k, j)
oCellRangeByPosition.setFormulaArray(oDataArray)
nEndRow = j + 1
Next i
End Sub

Sub DelFirstRow(sourceArr)
Dim i%, l%
l = UBound(sourceArr)-1
For i = 0 To l
sourceArr(i)=sourceArr(i+1)
Next i
ReDim Preserve sourceArr(l)
End Sub

[Hasim]

Большое спасибо.

Но переносится с ошибками, воспринимает как числа и даты вместо текста.

Сравни оригинал Writer и то, что в Calc.

07 стало 7

98-2-5 стало 35831

А нужно точно перенести - это для бухгалтера.

[вложение удалено Администратором]

[JohnSUN]

А... Тогда setFormulaArray замени на setDataArray, должно помочь (по идее во всех ячейках должны получится те самые строки с апострофами, которые стольким людям нервы попортили)

[Hasim]

Все отлично! Супер!

И никакие апострофы не получились.

Бухгалтер счастлива.

Спасибо!

[irafat]

Добрый день!
У меня почти такая же задача, но вставлены не таблицы, а нарисованые таблицы. Можно как нибудь эти нарисованые таблицы превратить в настоящие?
Образец во вложении.
Спасибо всем кто ответит.

[вложение удалено Администратором]

[kompilainenn]

У меня почти такая же задача, но вставлены не таблицы, а нарисованые таблицы.

а в чем разница? ваш файл с таблицами ничем не отличается от файла ТС в плане самих таблиц

[irafat]

Макрос ничего не делает!

[JohnSUN]

Макрос ничего не делает!

Ну, это не совсем так - он делает... Не очень много, но делает: считывает все текстовые таблицы из документа, убеждается, что их нет и завершает работу.
И много таких нарисованных таблиц нужно превратить в Calc'овские? Только этот документ или их будет больше?
И заодно: как быть со строками, где перечислены несколько корреспонденций через слово "или"?

[irafat]

Таких нарисованных таблиц очень много, больше 300 в документе. Таких документов может быть несколько.
Со строками, где перечислены несколько корреспонденций через слово "или", хотелось бы чтобы были отдельно. Вариант "или" под тем же номером или можно без номера, но сразу за тем, что с номером. Лучше всего слово "или" поставить вместо его номера, которого нет.
Надеюсь понятно объяснила.

[Hasim]

а в чем разница? ваш файл с таблицами ничем не отличается от файла ТС в плане самих таблиц

Нет там таблиц.
Таблицы нарисованы с помощью псевдографики, как раньше рисовали в DOS.


[вложение удалено Администратором]

[irafat]

Значит, никак нельзя?

[JohnSUN]

Не переживай - можно. И это не намного сложнее, чем "настоящие" таблицы:

Код Выделить Развернуть

REM  *****  BASIC  *****
REM GNU General Public License http://www.gnu.org/licenses/
REM
REM © Vladislav Orlov aka JohnSUN, Kiev, Ukraine, 2014
REM
REM mailto:johnsun@i.ua
REM Выбрать из текущего текстового документа все таблицы из четырёх колонок,
REM нарисованных псевдографикой, и перенести их содержимое в лист Calc
Sub getNonTable
REM Текстовый документ и его таблицы
Dim tDoc As Variant ' Текущий (текстовый) документ
Dim oSearchDesc As Variant ' Поисковый дескриптор
Dim aSearchResult As Variant ' Результат поиска (набор найденных абзацев)
Dim nCount As Long ' Их количество
Dim oneRow As Variant ' Один, очередной абзац
Dim sString As String ' Текст этого абзаца
Dim sHeader As String ' Строка заголовка (она нужна только один раз, остальные пропускать)
Dim oRowArray As Variant ' Отдельные "ячейки" из строки псевдотаблицы
REM Электронная таблица - первый лист
Dim cDoc As Variant ' Новая книга Calc
Dim oSheets As Variant ' Все её листы
Dim oSheet As Variant ' Первый лист
Dim oDataArray As Variant ' Массив для накапливания найденных данных (результат отбора)
Dim nEndRow As Long ' Номер самой последней строки массива результатов oDataArray
Dim oCellRangeByPosition As Variant
Dim i%, j%, k&
tDoc = ThisComponent
REM Просто найдем все строки (абзацы) в документе,
REM в которых попадается символ псевдографики "вертикальная черта" (│)
oSearchDesc = ThisComponent.createSearchDescriptor()
oSearchDesc.setSearchString("\│.*") ' Строка поиска "символ черты и сколько-то символов за ней до конца абзаца"
oSearchDesc.setPropertyValue("SearchRegularExpression",True)
aSearchResult = tDoc.findAll(oSearchDesc) ' Найти все такие строки
nCount = aSearchResult.getCount()-1
If nCount < 0 Then Exit Sub ' Ни одного символа "вертикальная черта" (│) в документе нет, нечего делать
oDataArray = Array() ' Пустой (пока) массив для результатов
REM Первую найденную строку будем считать общим заголовком таблицы, обработаем отдельно и будем пропускать в дальнейшем
oneRow = aSearchResult.getByIndex(0) ' Очередной найденный абзац
sHeader = oneRow.getString() ' Строка заголовков, которую нужно вывести один раз, а потом игнорировать
oRowArray = Split(sHeader, "│")
nEndRow = AppendToArray(oDataArray, Array(Trim(oRowArray(1)),Trim(oRowArray(2)),Trim(oRowArray(3)),Trim(oRowArray(4))))
For i = 1 to nCount
  oneRow = aSearchResult.getByIndex(i) ' Очередной найденный абзац
sString = oneRow.getString() ' Текст этого абзаца
oRowArray = Split(sString, "│")
If UBound(oRowArray) = 5 Then ' Разбираем только строки, в которых ровно пять разделителей (так было в образце)
If sString <> sHeader Then ' Не заголовок ли это таблицы?
If Trim(oRowArray(1)) = "" Then ' В певой колонке нет текста (номера)? Это может быть продолжением предыдущей строки
If Trim(oRowArray(4)) = "или" Then ' В последней колонке одно слово "или"? Это новая строка (вариант предыдущей проводки)
nEndRow = AppendToArray(oDataArray, Array("или"," "," "," "))
Else ' Это все-таки продолжение предыдущей строки
nEndRow = AppendDataToArray(oDataArray, Array(Trim(oRowArray(1)),Trim(oRowArray(2)),Trim(oRowArray(3)),Trim(oRowArray(4))))
EndIf
Else ' Что-то есть в первой колонке - это новая строка
nEndRow = AppendToArray(oDataArray, Array(Trim(oRowArray(1)),Trim(oRowArray(2)),Trim(oRowArray(3)),Trim(oRowArray(4))))
EndIf
EndIf
EndIf
Next i
REM Теперь создадим новую книгу Calc и в первый лист сбросим все накопленные данные
cDoc = StarDesktop.LoadComponentFromUrl("private:factory/scalc", "_blank", 0, Array())
oSheets = cDoc.getSheets()
oSheet = oSheets.getByIndex(0)
oCellRangeByPosition = oSheet.getCellRangeByPosition(0, 0, 3, nEndRow)
oCellRangeByPosition.setDataArray(oDataArray)
End Sub

REM Добавить в конец массива oData новый элемент со значением x
Function AppendToArray(oData(), ByVal x) As Long
Dim iUB As Integer  'Верхняя граница
Dim iLB As Integer  'Нижняя граница (обычно 0)
iUB = UBound(oData()) + 1
iLB = LBound(oData())
ReDim Preserve oData(iLB To iUB)
oData(iUB) = x
AppendToArray = iUB
End Function

REM Добавить в последний элемент массива значения из x
Function AppendDataToArray(oData(), x())
Dim iUB As Integer  'Верхняя граница
Dim iLx As Integer  'Нижняя граница x (обычно 0)
Dim iUx As Integer  'Верхняя граница x
Dim aData As Variant
Dim i%
iUB = UBound(oData())
iLx = LBound(x())
iUx = UBound(x())
aData = oData(iUB)
For i = iLx To iUx
aData(i) = Trim(aData(i)) + " " + Trim(x(i))
Next i
oData(iUB) = aData
AppendDataToArray = iUB
End Function


[irafat]

JohnSUN, спасибо большущее!!!
За ваши комментарии особенно. Я, правда, с функциями, которые там, не знакома, да и с макросами тоже не очень. Где можно про них прочитать? Попробую разобраться.

[celler]

Я тоже смотрю на макросы как на волшебство, поэтому регулярно довожу LO формулами до предела его возможностей. Попробовал вот и эту задачку решить. В результате для 50000 строк получилось около миллиона формул.
Там нужно скопировать всё в первый столбец, а затем всё из столбцов B-F скопировать в новую таблицу, отсортировать по столбцу с номерами операций, удалить все пустые строки и вновь отсортировать по порядку, а дальше остаётся только отформатировать нужным образом. Формулы только для 50000 строк, если в одном файле их больше, тогда придётся делать в несколько приёмов. И ещё не известно, каково максимальное количество строк в описаниях в графе "Содержание проводки",- я сделал максимум для 14 строк, если бывает больше, то нужно немного подкорректировать файл. Если будет больше 14 строк, то там появится красное предупреждение. Для Calc под виндовс такие файлы очень тяжелы, поэтому нужно делать либо в линуксе, либо в самом последнем LO 4.2. Если у кого-то файл не откроется, то приложил ещё облегчённую версию только для строк образца, нижний ряд с формулами там при необходимости можно скопировать на нужное количество строк.

[вложение удалено Администратором]