Условное форматирование на всех станицах книги (макрос)

private sub main
    dim p$, f$, t$, rw&, cl&, a(), i&
    dim wb as object, ws as object, c as object
    
    p="C:\Users\Gowan MTB\Desktop\EAR logs\"
    f=dir(p+"*.txt")
    if len(f) then wb=thiscomponent else exit sub
    
    do           
       wb.sheets.insertnewbyname(f,i)
       ws=wb.sheets(i):i=i+1:rw=0
       open p+f for input as #1
            do while not eof(#1)
               line input #1, t
               a=split(t)
               for cl=0 to ubound(a)
                   c=ws.getcellbyposition(cl,rw)
                   select case cl
                       case 0 to 2, 5 to 7
                          c.setvalue(a(cl))
                       case else
                          c.setstring(a(cl)) 
                   end select
               next
               rw=rw+1
            loop
       close #1
       setFormat ws, rw
       f=dir
    loop while len(f) 
end sub
 
sub setFormat(ws as object, rw&)
    dim r as object, cf as object 
 
    r=ws.getcellrangebyname("f1:f"+rw)
    cf=r.conditionalformat   
    
    condFormat "0.95", "" , "Good", 3, cf
    condFormat "0.9", "0.95", "Neutral", 7, cf
    condFormat "0.85", "0.8999", "Bad", 7, cf
    condFormat "0", "0.85", "Error", 7, cf
    
    r.conditionalformat=cf
End Sub
 
sub condFormat(formula1$, formula2$, style$, o&, cf as object)
    dim p(3) As new com.sun.star.beans.PropertyValue
    p(0).name="StyleName"
    p(0).value=style
    p(1).name="Operator"
    p(1).value=o
    p(2).name="Formula1"
    p(2).value=formula1
    if len(formula2) then
       p(3).name="Formula2"
       p(3).value=formula2
    end if       
    cf.addnew(p)
end sub

if rw then setFormat ws, rw

private sub main
    dim p$, f$, t$, rw&, cl&, a(), i&
    dim wb as object, ws as object, c as object
    
    p="C:\Users\g.nerovniy\Desktop\log\"
    f=dir(p+"*.txt")
    if len(f) then wb=thiscomponent else exit sub
    
    do           
       wb.sheets.insertnewbyname(f,i)
       ws=wb.sheets(i):i=i+1:rw=0
       open p+f for input as #1
            do while not eof(#1)
               line input #1, t
               a=split(t)
               for cl=0 to ubound(a)
                   c=ws.getcellbyposition(cl,rw)
                   select case cl
                       case 0 to 2, 5 to 7
                          c.setvalue(a(cl))
                       case else
                          c.setstring(a(cl)) 
                   end select
               next
               rw=rw+1
            loop
       close #1
       setFormat ws, rw
       f=dir
    loop while len(f) 
    oDoc = ThisComponent
 
oDoc.Sheets.removeByName("Лист1")
end sub
 
sub setFormat(ws as object, rw&)
    dim r as object, cf as object 
 
    r=ws.getcellrangebyname("f1:f"+rw)
    cf=r.conditionalformat   
    
    condFormat "0.95", "" , "Good", 3, cf
    condFormat "0.9", "0.95", "Neutral", 7, cf
    condFormat "0.85", "0.8999", "Bad", 7, cf
    condFormat "0", "0.85", "Error", 7, cf
    
    r.conditionalformat=cf
    
End Sub
 
sub condFormat(formula1$, formula2$, style$, o&, cf as object)
    dim p(3) As new com.sun.star.beans.PropertyValue
    p(0).name="StyleName"
    p(0).value=style
    p(1).name="Operator"
    p(1).value=o
    p(2).name="Formula1"
    p(2).value=formula1
    if len(formula2) then
       p(3).name="Formula2"
       p(3).value=formula2
    end if       
    cf.addnew(p)
 
 
end sub
 
 
sub delsave
 odoc=thiscomponent
 oSheet = oDoc.CurrentController.getActiveSheet()
 myrows=oSheet.getrows
 
 rowmax=3000
 rowmin=0
 
 For i=rowmax To rowmin step -1
 textnd = osheet.getcellbyposition(5,i).string
    If textnd >="0,95" Then
      myrows.removebyindex(i,1)
    End if   
 Next i
Dim args(0) As New com.sun.star.beans.PropertyValue
oDoc.storeToURL("file:///C:/Users/g.nerovniy/Desktop/mis.ods", args())
oDoc.close(true) 
end sub

case 0 to 2, 5 to 7

 
case 1 to 2, 5 to 7

private sub main
    dim p$, f$, t$, rw&, cl&, a()
    dim wb as object, ws as object, c as object
    dim args(0) As New com.sun.star.beans.PropertyValue
    
    p="C:\Users\g.nerovniy\Desktop\log\"
    f=dir(p+"*.txt"): if len(f)=0 then exit sub
    
    wb=thiscomponent: ws=wb.sheets(0)
    
    do
       open p+f for input as #1
            do while not eof(#1)
               line input #1, t
               a=split(t)
               for cl=0 to ubound(a)
                   'если в столбце а(5) значение <= 0,95
                        'пропускать эту строку 
                   c= ws.getcellbyposition(cl,rw)
                   select case cl
                       case 0 to 2, 5 to 7
                          c.setvalue(a(cl))
                         'c.изменить столбец 0
                            'если значение равно 1 == один:
                            'если значение равно 2== два:
                                'и так далее 
                       case else
                          c.setstring(a(cl)) 
                   end select
               next
               rw=rw+1
            loop
       close #1
       f=dir
    loop while len(f)
 
odoc=thiscomponent
oSheet = oDoc.CurrentController.getActiveSheet()
myrows=oSheet.getrows    
 
oDoc.storeToURL("file:///C:/Users/g.nerovniy/Desktop/mis.ods", args())
oDoc.close(true) 
end sub

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