Переписать макрос под Libre calc

Автор georgiy123, 10 апреля 2020, 09:36

0 Пользователи и 1 гость просматривают эту тему.

georgiy123

Всем привет ребята !
Человек с форума написал макрос , ну он работает только в эксель .
Можете помочь ?
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


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

economist

Цитата: georgiy123 от 10 апреля 2020, 09:36начинает ругатся на
Код:
Application.ScreenUpdating = False

Закомментируйте эту строку апострофом или словом REM. Она блокирует отрисовку и чуть ускоряет работу макроса. Её придется заменить, но это потом. Главное чтобы работал сам макрос.   
Руб. за сто, что Питоньяк
Любит водку и коньяк!
Потому что мне, без оных, -
Не понять его никак...

georgiy123

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