Форум поддержки пользователей. LibreOffice, Apache OpenOffice, OpenOffice.org

Форум поддержки пользователей. LibreOffice, Apache OpenOffice, OpenOffice.org

15 Апрель 2021, 19:59 *
Добро пожаловать, Гость. Пожалуйста, войдите или зарегистрируйтесь.
Вам не пришло письмо с кодом активации?

Войти
Новости: Доступно и просто о работе в офисных пакетах
 
   Начало   Помощь Поиск Войти Регистрация    задать вопрос  
Страниц: 1   Вниз
  Печать  
Автор Тема: Макрос MS Office портирвать для LibreOffice  (Прочитано 14633 раз)
0 Пользователей и 1 Гость смотрят эту тему.
li11amy
Участник
**
Offline Offline

Сообщений: 6


« Ответ #42937: 18 Август 2017, 13:24 »

цель сего действия?
Работа такая. Авторы сдают тексты в .doc(х), клиент хочет их в виде таблицы .xls(x). Их достаточно много, чтобы в ручную это делать было затруднительно.


где файл с макросом?
Прошу прощения, не нашла как убрать под кат.

Код:
Sub Auto_Import_Excel_2()
'ТРЕБУЕТСЯ ПОДКЛЮЧИТЬ БИБЛИОТЕКУ Microsoft Excel 12.0 (или 14.0) Object Library в Tools=>References
   
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .StatusBar = False
    End With
   
    Dim obj_Excel As Excel.Application 'Объектные переменные для MS Excel
    Dim obj_Workbook As Excel.Workbook 'Для книги
    Dim obj_Worksheet As Excel.Worksheet 'Для листа
    Dim obj_Range As Word.Range 'Для текста в MS Word
    Dim odj_Doc As Word.Document 'Для документа в MS Word основного
    Dim odj_Doc_time As Word.Document 'Для документа в MS Word временного
    Dim NumPages As Long
   
    Set odj_Doc = ActiveDocument
    'Запустим MS Excel
    Set obj_Excel = New Excel.Application
    Set obj_Workbook = obj_Excel.Workbooks.Add 'Добавим в Excel новую книгу
    Set obj_Worksheet = obj_Workbook.Worksheets(1) 'Присвоим переменной ссылку на первый лист книги
   
    NumPages = ActiveDocument.ComputeStatistics(wdStatisticPages) 'Количество страниц в Word

    For i = 1 To NumPages

        Documents.Add DocumentType:=wdNewBlankDocument 'Добавить временный документ
        Set odj_Doc_time = ActiveDocument

        odj_Doc.Activate
        Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i
        Set rgePages = Selection.Range
        Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i
        rgePages.End = Selection.Bookmarks("\Page").Range.End
        rgePages.Select: Selection.Copy
               
        odj_Doc_time.Activate: Selection.PasteAndFormat (wdFormatOriginalFormatting)
            Selection.WholeStory
            With Selection.Find
                .Text = "^p"
                .Replacement.Text = "+++"
                .Execute Replace:=wdReplaceAll
            End With
            With Selection.Find
                .Text = "^m"
                .Replacement.Text = ""
                .Execute Replace:=wdReplaceAll
            End With
        Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i
        Set rgePages = Selection.Range
        Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i
        rgePages.End = Selection.Bookmarks("\Page").Range.End
        rgePages.Select
       
        rgePages.Copy
        obj_Worksheet.Cells(i, 1).Select: ActiveSheet.Paste
        obj_Worksheet.Cells.Replace What:="+++", Replacement:="" & Chr(10) & "", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
       
        odj_Doc_time.Close (False) 'Закрыть документ
    Next i
       
    obj_Excel.Visible = True
   
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .StatusBar = True
    End With
   
End Sub

Ну, если речь только о форматировании символов, тогда возможно
Важно чтобы сохранялись абзацные отступы и списки, если есть. Все остальное не проблема поправить массово уже в таблице.

Записан
Страниц: 1   Вверх
  Печать  
 
Перейти в:  

Powered by MySQL Powered by PHP Powered by SMF 1.1.21 | SMF © 2006-2009, Simple Machines Valid XHTML 1.0! Valid CSS!