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

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

25 Май 2020, 09:40 *
Добро пожаловать, Гость. Пожалуйста, войдите или зарегистрируйтесь.
Вам не пришло письмо с кодом активации?

Войти
Новости: Часто задаваемые вопросы по LibreOffice и Apache OpenOffice.org
 
   Начало   Помощь Поиск Войти Регистрация    задать вопрос  
Страниц: 1   Вниз
  Печать  
Автор Тема: Переписать макрос под Libre calc  (Прочитано 814 раз)
0 Пользователей и 1 Гость смотрят эту тему.
georgiy123
Участник
**
Offline Offline

Сообщений: 25


« Стартовое сообщение: 10 Апрель 2020, 09:36 »

Всем привет ребята !
Человек с форума написал макрос , ну он работает только в эксель .
Можете помочь ?
Код:
Private Sub Test()
    Dim p$, f$, t$, cl&, a, rw2&, rw3&: rw3 = 1
    Dim wb As Workbook, ws As Worksheet ', r As Range = True
 
    p = "C:\Users\georgiy\Desktop\"
    f = Dir$(p + "*.txt"): If Len(f) = 0 Then Exit Sub
   
    Application.ScreenUpdating = False
    Set wb = ActiveWorkbook 'ThisWorkbook
    Set ws = wb.Worksheets(1): ws.Cells.Delete
    Do
         Open p + f For Input As #1
              t = Input(LOF(1), #1)
              a = Split(t, vbLf)
              cl = UBound(Split(a(0)))
              a = ArrToCell(a, UBound(a), rw2, cl)
         Close #1
         If rw2 Then
            ws.Cells(rw3, 1).Resize(rw2, 8) = a
            rw3 = rw3 + rw2 - 1: rw2 = 0
         End If
         f = Dir$
    Loop While Len(f)
   
    If rw3 > 1 Then setFormat ws.Range("F1:F" + CStr(rw3))
   
    Application.DisplayAlerts = False
    wb.SaveAs p + "mis.xls": wb.Close True
    Application.ScreenUpdating = True
End Sub
 
Private Function ArrToCell(a, rw1&, rw2&, cl&)
    ReDim a1(rw1, cl): Dim t$, up#, a2
    For rw1 = 0 To rw1
        t = Trim$(a(rw1))
        If Len(t) Then
           a2 = Split(t)
           up = Val(a2(5))
           If up <= 0.95 Then
              For cl = 0 To UBound(a2)
                  Select Case cl
                     Case 1, 2, 5 To 7
                      a1(rw2, cl) = Val(a2(cl))
                     Case 0
                      a1(rw2, 0) = NumToText(Val(a2(0)))
                     Case Else
                      a1(rw2, cl) = a2(cl)
                  End Select
              Next
              rw2 = rw2 + 1
           End If
        End If
    Next
    ArrToCell = a1
End Function
 
Private Function NumToText$(i&)
    Select Case i
        Case 1 To 10: NumToText = Choose(i, _
        "Один", "Два", "Три", "Четыре", "Пять", "Шесть", "Семь", "Восемь", "Девять", "Десять")
    End Select
End Function
 
Private Sub setFormat(r As Range)
    Dim cf As FormatConditions
    Set cf = r.FormatConditions
   
    With cf.Add(xlCellValue, xlBetween, 0, 0.855)
         .Interior.Color = 255:   .StopIfTrue = True
    End With
    With cf.Add(xlCellValue, xlBetween, 0.855, 0.8999)
         .Interior.Color = 49407: .StopIfTrue = True
    End With
    With cf.Add(xlCellValue, xlBetween, 0.9, 0.95)
         .Interior.Color = 65535: .StopIfTrue = True
    End With
End Sub

p.s.

Сейчас он ругается на  Workbook и  Worksheet
После того как я вставил Option VBASupport 1 как указано на сайте https://help.libreoffice.org/6.4/ru/text/sbasic/shared/03103350.html
начинает ругатся на 
Код:
Application.ScreenUpdating = False


вложил файл который должен быть по пути в макросе

* forumoo.txt (0.34 Кб - загружено 12 раз.)
Записан
economist
Форумчанин
***
Offline Offline

Сообщений: 1 185


« Ответ #1: 10 Апрель 2020, 14:52 »

начинает ругатся на
Код:
Application.ScreenUpdating = False

Закомментируйте эту строку апострофом или словом REM. Она блокирует отрисовку и чуть ускоряет работу макроса. Её придется заменить, но это потом. Главное чтобы работал сам макрос.   
Записан

Руб. за сто, что Питоньяк
Любит водку и коньяк!
Потому что мне, без оных, -
Не понять его никак...
georgiy123
Участник
**
Offline Offline

Сообщений: 25


« Ответ #2: 13 Апрель 2020, 11:32 »

Закоментировал  ,теперь ругается на другую строку


* на форум.jpg (32.23 Кб, 523x338 - просмотрено 13 раз.)
Записан
Страниц: 1   Вверх
  Печать  
 
Перейти в:  

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