Attribute VB_Name = "Функции"

Function СЖ(st As String) As String
    СЖ = Trim(st)
End Function

Function СИМ(n As Integer) As String
    СИМ = Chr(n)
End Function



Function КОДДОХОДА(inc As String) As String
    If VBA.Len(inc) <> 20 Then
        КОДДОХОДА = inc
    Else
        КОДДОХОДА = VBA.Mid(inc, 1, 3) & " " & VBA.Mid(inc, 4, 1) & " " & VBA.Mid(inc, 5, 2) & " " & VBA.Mid(inc, 7, 2) & " " & VBA.Mid(inc, 9, 3) & " " & VBA.Mid(inc, 12, 2) & " " & VBA.Mid(inc, 14, 4) & " " & VBA.Mid(inc, 18, 3)
    End If
End Function

Function NVL(st As Variant, wt As Variant) As Variant
         If Not IsNull(st) And Not IsEmpty(st) Then
            If CStr(st) <> "" Then
                NVL = st
            Else
                NVL = wt
            End If
         Else
            NVL = wt
         End If
End Function

Function N_SS(ss_st As String, ss_n As Integer) As String
    N_SS = Trim(Mid(ss_st, (ss_n - 1) * 12 + 1, 12))
End Function

Function МЕСЯЦПРОП(dt As Date, padeg As Boolean) As String
Dim months(12) As String ' Массив месяцев в зависимости от падежа
    months(1) = "январь      января      "
    months(2) = "февраль     февраля     "
    months(3) = "март        марта       "
    months(4) = "апрель      апреля      "
    months(5) = "май         мая         "
    months(6) = "июнь        июня        "
    months(7) = "июль        июля        "
    months(8) = "август      августа     "
    months(9) = "сентябрь    сентября    "
    months(10) = "октябрь     октября     "
    months(11) = "ноябрь      ноября      "
    months(12) = "декабрь     декабря     "
    МЕСЯЦПРОП = IIf(padeg, N_SS(months(Month(dt)), 2), N_SS(months(Month(dt)), 1))
End Function

Function МЕСЯЦПРОП2(mes As Integer, padeg As Boolean) As String
Dim months(12) As String ' Массив месяцев в зависимости от падежа
    months(1) = "январь      января      "
    months(2) = "февраль     февраля     "
    months(3) = "март        марта       "
    months(4) = "апрель      апреля      "
    months(5) = "май         мая         "
    months(6) = "июнь        июня        "
    months(7) = "июль        июля        "
    months(8) = "август      августа     "
    months(9) = "сентябрь    сентября    "
    months(10) = "октябрь     октября     "
    months(11) = "ноябрь      ноября      "
    months(12) = "декабрь     декабря     "
    МЕСЯЦПРОП2 = IIf(padeg, N_SS(months(mes), 2), N_SS(months(mes), 1))
End Function

Function ДАТАПРОП(dt As Date, n As Integer) As String
    If dt <> 0 Then
        If n > 0 Then
            ДАТАПРОП = Right("0" & Trim(Str(Day(dt))), 2) & "." & Right("0" & Trim(Str(Month(dt))), 2) & "." & IIf(n = 4, Trim(Str(Year(dt))), Right(Trim(Str(Year(dt))), 2))
        Else
            ДАТАПРОП = Right("0" & Trim(Str(Day(dt))), 2) & " " & МЕСЯЦПРОП(dt, True) & " " & Trim(Str(Year(dt)))
        End If
    Else
        ДАТАПРОП = ""
    End If
End Function

Function ЧИСЛОПРОП(nm_num As Double, _
            nm_propis As Boolean, _
            nm_padeg As Boolean, _
            nm_equ As Boolean, _
            Optional bNotMoney As Boolean) As String
Dim nm_sn As String, nm_snum As String, nm_cs As String, nm_SSP As String, _
    nm_i As Long, nm_c1 As Integer, nm_c2 As Integer, nm_c3 As Integer, nPosPoint As Integer
Dim nm_ST(7) As String ' Массив окончаний в зависимости от падежа
  nm_ST(1) = "рубль       рубля       рублей      "
  nm_ST(2) = "тысяча      тысячи      тысяч       "
  nm_ST(3) = "миллион     миллиона    миллионов   "
  nm_ST(4) = "миллиард    миллиарда   миллиардов  "
  nm_ST(5) = "триллион    триллиона   триллионов  "
  nm_ST(6) = "триллиард   триллиарда  триллиардов "
Dim nm_SR(10) As String ' Массив названий цифр разных порядков
  nm_SR(1) = "                                                десять    "
  nm_SR(2) = "сто         десять      один        одна        одиннадцать"
  nm_SR(3) = "двести      двадцать    два         две         двенадцать"
  nm_SR(4) = "триста      тридцать    три         три         тринадцать"
  nm_SR(5) = "четыреста   сорок       четыре      четыре      четырнадцать"
  nm_SR(6) = "пятьсот     пятьдесят   пять        пять        пятнадцать"
  nm_SR(7) = "шестьсот    шестьдесят  шесть       шесть       шестнадцать"
  nm_SR(8) = "семьсот     семьдесят   семь        семь        семнадцать"
  nm_SR(9) = "восемьсот   восемьдесят восемь      восемь      восемнадцать"
  nm_SR(10) = "девятьсот   девяносто   девять      девять      девятнадцать"
' Массив для учета падежа в зависимости от последней цифры
  nm_SSP = "3           1           2           2           2           3           3           3           3           3           "
' Начало
  nm_sn = ""
  nm_snum = Trim(Format(nm_num, "###0.00"))
  nPosPoint = InStr(nm_snum, Mid(Format(0.1, "#.0"), 1, 1))
  If nm_propis Then
    nm_skop = Mid(nm_snum, nPosPoint + 1, 2)
    nm_snum = "00" + Mid(nm_snum, 1, nPosPoint - 1)
    nm_i = Int(Len(nm_snum) / 3)
    nm_snum = Mid(nm_snum, Len(nm_snum) - nm_i * 3 + 1, nm_i * 3)
    If nm_snum = "000" And nm_i = 1 Then
        nm_sn = "Ноль" + IIf(Not bNotMoney, " рублей ", "")
    Else
        Do While nm_i > 0
            nm_c2 = Int(Val(Mid(nm_snum, 2, 1)))
            nm_c3 = Int(Val(Mid(nm_snum, 3, 1)))
            nm_cs = Trim(N_SS(nm_SR(Int(Val(Mid(nm_snum, 1, 1))) + 1), 1) + " " + _
                    Trim(IIf(nm_c2 = 1, N_SS(nm_SR(nm_c3 + 1), 5), _
            N_SS(nm_SR(nm_c2 + 1), 2) + " " + IIf(nm_i = 2, N_SS(nm_SR(nm_c3 + 1), 4), N_SS(nm_SR(nm_c3 + 1), 3)))))
            If (nm_cs <> "") Or (nm_i = 1) Then
                nm_sn = Trim(nm_sn + nm_cs) + IIf(Not bNotMoney Or nm_i > 1, " " + IIf(nm_c2 = 1, N_SS(nm_ST(nm_i), 3), _
                        N_SS(nm_ST(nm_i), Val(N_SS(nm_SSP, nm_c3 + 1)))) + " ", "")
            End If
            nm_snum = IIf(nm_i > 1, Mid(nm_snum, 4, (nm_i - 1) * 3), "")
            nm_i = nm_i - 1
        Loop
    End If
    If Not (nm_equ And (nm_skop = "00")) And Not bNotMoney Then
        If (Not nm_padeg) Or (Int(Val(Mid(nm_skop, 1, 1))) = 1) Or (Val(N_SS(nm_SSP, Int(Val(Mid(nm_skop, 2, 1))) + 1)) = 3) Then
            nm_sn = nm_sn + nm_skop + " копеек"
        Else
            If Int(Val(Mid(nm_skop, 2, 1))) = 1 Then
                nm_sn = nm_sn + nm_skop + " копейка"
            Else
                nm_sn = nm_sn + nm_skop + " копейки"
            End If
        End If
    End If
    If nm_num < 0 Then
        nm_sn = "минус " & nm_sn
    End If
  Else
    nm_sn = IIf((Mid(nm_snum, Len(nm_snum) - 1, 2) = "00") And nm_equ, _
            Mid(nm_snum, 1, Len(nm_snum) - 3) + " =", nm_snum)
  End If
  ЧИСЛОПРОП = UCase(Mid(nm_sn, 1, 1)) + LCase(Mid(nm_sn, 2, Len(nm_sn) - 1))
End Function
        
Function ИНН(lcString As String, lcCPPU As String)
Dim lcINN As String
'    ИНН = Left(Trim(Str(Val(lcString))) + String(11, "0"), 11) + IIf(lcCPPU <> "", " КПП " + Trim(lcCPPU) + " ", " ")
'    lcINN = Trim(lcString)
'    lcINN = IIf(lcINN = "0000000000" Or lcINN = "000000000000", "НЕТ", lcINN)
'    ИНН = lcINN + IIf(lcCPPU <> "", " КПП " + Trim(lcCPPU) + " ", " ")
    ИНН = Trim(lcString) + IIf(lcCPPU <> "", " КПП " + Trim(lcCPPU) + " ", " ")
End Function

Function НОРМЗНАЧ(lcString As String) As String
    НОРМЗНАЧ = Trim(Str(Val(lcString)))
End Function

Function НОМЕРПП(rRange As Range, Optional rCell As Range, Optional bNotEmpty As Boolean) As Integer
Dim i As Long, cValue As String, cOldValue As String, cNewValue As String, rC As Range, b As Boolean
    b = True
    If rCell Is Nothing Then
        cValue = ""
        b = False
    Else
        cValue = rCell.Value
    End If
    cOldValue = rRange(1, 1)
    i = 1
    If bNotEmpty And cOldValue = "" Then i = 0
    For Each rC In rRange
        cNewValue = rC.Value
        If (cNewValue <> cOldValue) And (Not bNotEmpty Or cNewValue <> "") Then
            cOldValue = cNewValue
            i = i + 1
        End If
        If (cNewValue = cValue) And b Then Exit For
    Next rC
    НОМЕРПП = i
End Function

Function ДАТАСЛЕД(dt As Date, k As Integer) As String
Dim n As Integer
 If dt <> 0 Then
   n = Weekday(dt)
   If n >= 6 Then
     dt = dt + (8 - n)
   End If
   dt = dt + 1
   ДАТАСЛЕД = ДАТАПРОП(dt, k)
 Else
   ДАТАСЛЕД = ""
 End If
End Function

Function СУММСАЛЬДО(rKeys As Range, rDeb As Range, rCred As Range, nMode As Integer) As Double
Dim cValue As String, cOldValue As String, cNewValue As String, rC As Range
Dim dSumOborot As Double, dSumSaldo As Double, nRow As Integer
    dSumSaldo = 0
    dSumOborot = 0
    nRow = 0
    cOldValue = rKeys(1, 1)
    For Each rC In rKeys
        cNewValue = rC.Value
        nRow = nRow + 1
        If cNewValue <> cOldValue Then
            dSumOborot = dSumOborot + IIf(nMode = 1, IIf(dSumSaldo < 0, -dSumSaldo, 0), IIf(dSumSaldo > 0, dSumSaldo, 0))
            cOldValue = cNewValue
            dSumSaldo = 0
        End If
        dSumSaldo = dSumSaldo - rDeb(nRow, 1) + rCred(nRow, 1)
    Next rC
    dSumOborot = dSumOborot + IIf(nMode = 1, IIf(dSumSaldo < 0, -dSumSaldo, 0), IIf(dSumSaldo > 0, dSumSaldo, 0))
    СУММСАЛЬДО = dSumOborot
End Function

Function ССУММ(rF As Range) As Double
Dim dSum As Double, rC As Range
    dSum = 0
    For Each rC In rF
      If (rC.Value <> "") Then
         If Val(rC.Value) = 0 Or (Mid(rC.Value, 3, 1) = "." And Mid(rC.Value, 6, 1) = ".") Then
              dSum = dSum + 1
         Else
              dSum = dSum + Val(rC.Value)
         End If
      Else
      End If
    Next rC
    ССУММ = dSum
End Function

Function НОМЕРПП2(rRange As Range, bNotEmpty As Boolean) As Integer
Dim i As Long, cValue As String, cOldValue As String, cNewValue As String, rC As Range, b As Boolean
    cOldValue = rRange(1, 1)
    i = 1
    If bNotEmpty And cOldValue = "" Then i = 0
    For Each rC In rRange
        cNewValue = rC.Value
        If (cNewValue <> cOldValue) And (Not bNotEmpty Or cNewValue <> "") Then
            cOldValue = cNewValue
            i = i + 1
        End If
    Next rC
    НОМЕРПП2 = i
End Function

Function ДУБЛЬ(r As Range) As Boolean
Dim rValue
    If r.Count > 1 Then
        ДУБЛЬ = (r(r.Count).Value = r(r.Count - 1).Value)
    Else
        ДУБЛЬ = False
    End If
End Function

Function ПОХОЖЕ(lcShabl As String, lcString) As Boolean
    ПОХОЖЕ = (lcString Like lcShabl)
End Function

Function НЕПУСТО(r As Range) As String
Dim rValue As Range, cRes As String
    cRes = ""
    For Each rValue In r
        If rValue.Value <> "" Then
            cRes = rValue.Value
            Exit For
        End If
    Next rValue
    НЕПУСТО = cRes
End Function

Function ЗНАЧЕСЛИ(rKrit As Range, Krit As Variant, rVal As Range)
Dim r As Range
    For Each r In rKrit
        If r.Value = Krit Then
            ЗНАЧЕСЛИ = rVal.Parent.Cells(r.row, rVal.Column).Value
            Exit Function
        End If
    Next r
    ЗНАЧЕСЛИ = ""
End Function

Function ЗНАЧЕСЛИ2(rKrit1 As Range, Krit1 As Variant, rKrit2 As Range, Krit2 As Variant, rVal As Range)
Dim i As Long
    For i = rVal.row To rVal.row + rVal.Rows.Count - 1
        If rVal.Parent.Cells(i, rKrit1.Column).Value = Krit1 And _
          rVal.Parent.Cells(i, rKrit2.Column).Value = Krit2 Then
            ЗНАЧЕСЛИ2 = rVal.Parent.Cells(i, rVal.Column).Value
            Exit Function
        End If
    Next i
    ЗНАЧЕСЛИ2 = ""
End Function

Function ЗНАЧЕСЛИ3(rKrit1 As Range, Krit1 As Variant, rKrit2 As Range, Krit2 As Variant, rKrit3 As Range, Krit3 As Variant, rVal As Range)
Dim i As Long

    For i = rVal.row To rVal.row + rVal.Rows.Count - 1
        If rVal.Parent.Cells(i, rKrit1.Column).Value = Krit1 And _
          rVal.Parent.Cells(i, rKrit2.Column).Value = Krit2 And _
          rVal.Parent.Cells(i, rKrit3.Column).Value = Krit3 Then
            ЗНАЧЕСЛИ3 = rVal.Parent.Cells(i, rVal.Column).Value
            Exit Function
        End If
    Next i
    ЗНАЧЕСЛИ3 = ""
End Function

Function СРЕДЕСЛИ(r1 As Range, k1 As Variant, rs As Range) As Double
Dim s As Double, i As Long, c As Long
    s = 0
    c = 0
    For i = rs.row To rs.row + rs.Rows.Count - 1
        If r1.Parent.Cells(i, r1.Column).Value = k1 Then
            s = s + rs.Parent.Cells(i, rs.Column).Value
            c = c + 1
        End If
    Next i
    If c = 0 Then c = 1
    СРЕДЕСЛИ = s / c
End Function

Function СРЕДЕСЛИ2(r1 As Range, k1 As Variant, r2 As Range, k2 As Variant, rs As Range) As Double
Dim s As Double, i As Long, c As Long
    s = 0
    c = 0
    For i = rs.row To rs.row + rs.Rows.Count - 1
        If r1.Parent.Cells(i, r1.Column).Value = k1 And r2.Parent.Cells(i, r2.Column).Value = k2 Then
            s = s + rs.Parent.Cells(i, rs.Column).Value
            c = c + 1
        End If
    Next i
    If c = 0 Then c = 1
    СРЕДЕСЛИ2 = s / c
End Function

Function СРЕДЕСЛИ3(r1 As Range, k1 As Variant, r2 As Range, k2 As Variant, r3 As Range, k3 As Variant, rs As Range) As Double
Dim s As Double, i As Long, c As Long
    s = 0
    c = 0
    For i = rs.row To rs.row + rs.Rows.Count - 1
        If r1.Parent.Cells(i, r1.Column).Value = k1 And _
            r2.Parent.Cells(i, r2.Column).Value = k2 And _
            r3.Parent.Cells(i, r3.Column).Value = k3 Then
            s = s + rs.Parent.Cells(i, rs.Column).Value
            c = c + 1
        End If
    Next i
    If c = 0 Then c = 1
    СРЕДЕСЛИ3 = s / c
End Function

Function СУММЕСЛИ2(r1 As Range, k1 As Variant, r2 As Range, k2 As Variant, rs As Range) As Double
Dim s As Double, i As Long
    s = 0
    For i = rs.row To rs.row + rs.Rows.Count - 1
        If r1.Parent.Cells(i, r1.Column).Value = k1 And r2.Parent.Cells(i, r2.Column).Value = k2 Then s = s + rs.Parent.Cells(i, rs.Column).Value
    Next i
    СУММЕСЛИ2 = s
End Function

Function СУММЕСЛИ3(r1 As Range, k1 As Variant, r2 As Range, k2 As Variant, r3 As Range, k3 As Variant, rs As Range) As Double
Dim s As Double, i As Long
    s = 0
    For i = rs.row To rs.row + rs.Rows.Count - 1
        If r1.Parent.Cells(i, r1.Column).Value = k1 And _
            r2.Parent.Cells(i, r2.Column).Value = k2 And _
            r3.Parent.Cells(i, r3.Column).Value = k3 Then s = s + rs.Parent.Cells(i, rs.Column).Value
    Next i
    СУММЕСЛИ3 = s
End Function

Function СУММЕСЛИ4(r1 As Range, k1 As Variant, r2 As Range, k2 As Variant, r3 As Range, k3 As Variant, r4 As Range, k4 As Variant, rs As Range) As Double
Dim s As Double, i As Long
    s = 0
    For i = rs.row To rs.row + rs.Rows.Count - 1
        If r1.Parent.Cells(i, r1.Column).Value = k1 And _
            r2.Parent.Cells(i, r2.Column).Value = k2 And _
            r3.Parent.Cells(i, r3.Column).Value = k3 And _
            r4.Parent.Cells(i, r4.Column).Value = k4 Then s = s + rs.Parent.Cells(i, rs.Column).Value
    Next i
    СУММЕСЛИ4 = s
End Function

Function СУММЕСЛИ5(r1 As Range, k1 As Variant, r2 As Range, k2 As Variant, r3 As Range, k3 As Variant, r4 As Range, k4 As Variant, r5 As Range, k5 As Variant, rs As Range) As Double
Dim s As Double, i As Long
    s = 0
    For i = rs.row To rs.row + rs.Rows.Count - 1
        If r1.Parent.Cells(i, r1.Column).Value = k1 And _
            r2.Parent.Cells(i, r2.Column).Value = k2 And _
            r3.Parent.Cells(i, r3.Column).Value = k3 And _
            r4.Parent.Cells(i, r4.Column).Value = k4 And _
            r5.Parent.Cells(i, r5.Column).Value = k5 Then s = s + rs.Parent.Cells(i, rs.Column).Value
    Next i
    СУММЕСЛИ5 = s
End Function

Sub delEqStr(nFirstRow As Long, nCheckColumnCount As Integer, nCheckColumn As Integer)
Dim row As Long, j As Integer, flag As Boolean

    For Each sh In ActiveWorkbook.Sheets
        sh.Select
        If sh.Name <> "Данные" And sh.Name <> "Документ" Then
            row = nFirstRow
            While ActiveSheet.Cells(row, nCheckColumn) <> ""
                flag = False
                For i = 1 To nCheckColumnCount
                    If VBA.Trim(ActiveSheet.Cells(row, i).Text) <> VBA.Trim(ActiveSheet.Cells(row - 1, i).Text) Then
                        flag = True
                        Exit For
                    End If
                Next
                If Not flag Then
                    ActiveSheet.Rows(row).Delete
                Else
                    row = row + 1
                End If
            Wend
        End If
    Next sh

End Sub

Function ИЗВЛЕЧПОШАБЛОНУСПРАВА(cString As String, cShabl1 As String, Optional cShabl2 As String = "", Optional cShabl3 As String = "", Optional cShabl4 As String = "") As String
Dim cShabl As String, i As Integer
    If cShabl1 <> "" And cString Like "*" + cShabl1 + "*" Then
        cShabl = cShabl1
    Else
        If cShabl2 <> "" And cString Like "*" + cShabl2 + "*" Then
            cShabl = cShabl2
        Else
            If cShabl3 <> "" And cString Like "*" + cShabl3 + "*" Then
                cShabl = cShabl3
            Else
                If cShabl4 <> "" And cString Like "*" + cShabl4 + "*" Then
                    cShabl = cShabl4
                Else
                    ИЗВЛЕЧПОШАБЛОНУСПРАВА = cString
                    Exit Function
                End If
            End If
        End If
    End If
    i = 1
    Do While i < Len(cString)
        If Not Left(cString, i) Like "*" + cShabl Then
            i = i + 1
        Else
            Exit Do
        End If
    Loop
    If i = Len(cString) Then i = 0
    ИЗВЛЕЧПОШАБЛОНУСПРАВА = Mid(cString, i + 1)
End Function

Function ИЗВЛЕЧПОШАБЛОНУСЛЕВА(cString As String, cShabl1 As String, Optional cShabl2 As String = "", Optional cShabl3 As String = "", Optional cShabl4 As String = "") As String
Dim cShabl As String, i As Integer
    If cShabl1 <> "" And cString Like "*" + cShabl1 + "*" Then
        cShabl = cShabl1
    Else
        If cShabl2 <> "" And cString Like "*" + cShabl2 + "*" Then
            cShabl = cShabl2
        Else
            If cShabl3 <> "" And cString Like "*" + cShabl3 + "*" Then
                cShabl = cShabl3
            Else
                If cShabl4 <> "" And cString Like "*" + cShabl4 + "*" Then
                    cShabl = cShabl4
                Else
                    ИЗВЛЕЧПОШАБЛОНУСЛЕВА = cString
                    Exit Function
                End If
            End If
        End If
    End If
    i = 1
    Do While i < Len(cString)
        If Not Right(cString, i) Like cShabl + "*" Then
            i = i + 1
        Else
            Exit Do
        End If
    Loop
    If i = Len(cString) Then i = 0
    ИЗВЛЕЧПОШАБЛОНУСЛЕВА = Left(cString, Len(cString) - i)
End Function

Function ATC(what As String, where As String) As Integer
    ATC = InStr(1, where, what, vbTextCompare)
End Function

Sub SetSheetsHeader(cNameCell As String)
Dim oDir As Object, oSheet As Object, i As Integer, cSheet As String, cTitle As String
    Sheets.Add
    Set oDir = Application.ActiveSheet
    oDir.Name = "Оглавление"
    For i = 1 To Application.ActiveWorkbook.Sheets.Count
        If Application.ActiveWorkbook.Sheets(i).Name <> "Оглавление" Then
            cSheet = Application.ActiveWorkbook.Sheets(i).Name
            cTitle = VBA.Trim(Application.ActiveWorkbook.Sheets(i).Range(cNameCell).Value)
            cTitle = VBA.IIf(cTitle = "", cSheet, cTitle)
            
            oDir.Cells(i + 1, 2).Select
            oDir.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & cSheet & "'!A1", TextToDisplay:=cTitle
        End If
    Next i
End Sub

Sub CorrectTextFormat()
Dim c As Object, firstAddress As String, n1 As Integer, n2 As Integer, s As Integer
'    Application.FindFormat.NumberFormat = "@"
    For Each sh In ActiveWorkbook.Sheets
        If sh.Name <> "ServPath" Then
        sh.Select
        Set c = Cells.Find(what:="##########", After:=ActiveCell, LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False)
        If Not c Is Nothing Then
            Do
                c.NumberFormat = "General"
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing
        End If
        
        Set c = Cells.Find(what:="#HB", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Do
                ActiveSheet.HPageBreaks.Add Before:=c
                c.Value = ""
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing
        End If
    
        Set c = Cells.Find(what:="@Ж", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Do
                c.Value = StrReplace(c.Value, "@Ж", "")
                c.Font.Bold = True
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing
        End If
        
        Set c = Cells.Find(what:="@Ч", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Do
                c.Value = StrReplace(c.Value, "@Ч", "")
                c.Font.Underline = xlUnderlineStyleSingle
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing
        End If
        
        Set c = Cells.Find(what:="@К", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Do
                c.Value = StrReplace(c.Value, "@К", "")
                c.Font.Italic = True
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing
        End If
                
        Set c = Cells.Find(what:="@Р/", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Do
                n1 = InStr(1, c.Value, "@Р/")
                n2 = InStr(n1 + 3, c.Value, "/")
                If n2 > 0 Then
                    s = Val(Mid(c.Value, n1 + 3, n2 - n1 - 3))
                    c.Value = Mid(c.Value, 1, n1 - 1) + Mid(c.Value, n2 + 1)
                    If s > 0 Then
                        c.Font.Size = s
                    End If
                Else
                    c.Value = StrReplace(c.Value, "@Р/", "")
                End If
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing
        End If
                
                
        Set c = Cells.Find(what:="$Ж", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Do
                c.Value = StrReplace(c.Value, "$Ж", "")
                c.MergeArea.EntireRow.Font.Bold = True
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing
        End If
        
        Set c = Cells.Find(what:="$Ч", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Do
                c.Value = StrReplace(c.Value, "$Ч", "")
                c.MergeArea.EntireRow.Font.Underline = xlUnderlineStyleSingle
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing
        End If
        
        Set c = Cells.Find(what:="$К", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Do
                c.Value = StrReplace(c.Value, "$К", "")
                c.MergeArea.EntireRow.Font.Italic = True
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing
        End If
                
        Set c = Cells.Find(what:="$Р/", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Do
                n1 = InStr(1, c.Value, "$Р/")
                n2 = InStr(n1 + 3, c.Value, "/")
                If n2 > 0 Then
                    s = Val(Mid(c.Value, n1 + 3, n2 - n1 - 3))
                    c.Value = Mid(c.Value, 1, n1 - 1) + Mid(c.Value, n2 + 1)
                    If s > 0 Then
                        c.MergeArea.EntireRow.Font.Size = s
                    End If
                Else
                    c.Value = StrReplace(c.Value, "$Р/", "")
                End If
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing
        End If
        
        
        Set c = Cells.Find(what:="$Л", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Do
                c.Value = StrReplace(c.Value, "$Л", "")
                c.MergeArea.EntireRow.HorizontalAlignment = xlLeft
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing
        End If
        Set c = Cells.Find(what:="$П", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Do
                c.Value = StrReplace(c.Value, "$П", "")
                c.MergeArea.EntireRow.HorizontalAlignment = xlRight
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing
        End If
        Set c = Cells.Find(what:="$Ц", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Do
                c.Value = StrReplace(c.Value, "$Ц", "")
                c.MergeArea.EntireRow.HorizontalAlignment = xlCenter
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing
        End If
        Set c = Cells.Find(what:="$В", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Do
                c.Value = StrReplace(c.Value, "$В", "")
                c.MergeArea.EntireRow.VerticalAlignment = xlTop
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing
        End If
        Set c = Cells.Find(what:="$Н", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Do
                c.Value = StrReplace(c.Value, "$Н", "")
                c.MergeArea.EntireRow.VerticalAlignment = xlBottom
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing
        End If
        Set c = Cells.Find(what:="$С", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Do
                c.Value = StrReplace(c.Value, "$С", "")
                c.MergeArea.EntireRow.VerticalAlignment = xlCenter
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing
        End If
        
        
        Set c = Cells.Find(what:="@Л", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Do
                c.Value = StrReplace(c.Value, "@Л", "")
                c.HorizontalAlignment = xlLeft
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing
        End If
        Set c = Cells.Find(what:="@П", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Do
                c.Value = StrReplace(c.Value, "@П", "")
                c.HorizontalAlignment = xlRight
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing
        End If
        Set c = Cells.Find(what:="@Ц", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Do
                c.Value = StrReplace(c.Value, "@Ц", "")
                c.HorizontalAlignment = xlCenter
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing
        End If
        Set c = Cells.Find(what:="@В", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Do
                c.Value = StrReplace(c.Value, "@В", "")
                c.VerticalAlignment = xlTop
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing
        End If
        Set c = Cells.Find(what:="@Н", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Do
                c.Value = StrReplace(c.Value, "@Н", "")
                c.VerticalAlignment = xlBottom
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing
        End If
        Set c = Cells.Find(what:="@С", LookIn:=xlValues, LookAt:=xlPart)
        If Not c Is Nothing Then
            Do
                c.Value = StrReplace(c.Value, "@С", "")
                c.VerticalAlignment = xlCenter
                Set c = Cells.FindNext(c)
            Loop While Not c Is Nothing
        End If
        
                
                End If
    Next sh
End Sub

Sub CreatePDF417()
Dim lcValue As String, p As Object
    For Each sh In ActiveWorkbook.Sheets
        sh.Select
        With ActiveSheet.Cells
            Set c = .Find(what:="PDF417", LookIn:=xlValues, LookAt:=xlPart)
            If Not c Is Nothing Then
                Do
                    lcValue = Mid(c.Value, 8)
                    c.Value = ""
                    On Error GoTo bc2:
                    Set p = ActiveSheet.OLEObjects.Add(ClassType:="PDF417ActiveX.PDF417Ctrl.1", Link:= _
                        False, DisplayAsIcon:=False, Left:=c.Left, Top:=c.Top, Width:=c.MergeArea.Width, _
                        Height:=c.MergeArea.Height)
                    p.Object.DataToEncode = lcValue
bc2:                On Error GoTo 0
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing
            End If
        End With
    Next sh
End Sub

Sub CreateBarCode128()
Dim lcValue As String, bar As Object
    For Each sh In ActiveWorkbook.Sheets
        sh.Select
        With ActiveSheet.Cells
            Set c = .Find(what:="BAR128", LookIn:=xlValues, LookAt:=xlPart)
            If Not c Is Nothing Then
                Do
                    lcValue = Mid(c.Value, 8)
                    c.Value = ""
                    On Error GoTo bc1:
                    Set bar = CreateObject("Keysystems.Barcodes.BarCode128")
                    bar.Text = lcValue
                    bar.SaveImage "bar128.bmp", BarCodeImageFormat_Bmp
                    c.Select
                    ActiveSheet.Pictures.Insert("bar128.bmp").Select
                    Selection.ShapeRange.LockAspectRatio = msoFalse
                    Selection.ShapeRange.Height = c.MergeArea.Height
                    Selection.ShapeRange.Width = c.MergeArea.Width
                    Selection.ShapeRange.Top = c.MergeArea.Top
                    Selection.ShapeRange.Left = c.MergeArea.Left
bc1:                On Error GoTo 0
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing
            End If
        End With
    Next sh
End Sub

Sub CreateBarCode417()
Dim lcValue As String, bar As Object
    For Each sh In ActiveWorkbook.Sheets
        sh.Select
        With ActiveSheet.Cells
            Set c = .Find(what:="BAR417", LookIn:=xlValues, LookAt:=xlPart)
            If Not c Is Nothing Then
                Do
                    lcValue = Mid(c.Value, 8)
                    c.Value = ""
                    On Error GoTo bc3:
                    Set bar = CreateObject("Keysystems.Barcodes.BarCodePDF417")
                    bar.Text = lcValue
                    bar.SaveImage "bar417.bmp", BarCodeImageFormat_Bmp
                    c.Select
                    ActiveSheet.Pictures.Insert("bar417.bmp").Select
                    Selection.ShapeRange.LockAspectRatio = msoFalse
                    Selection.ShapeRange.Height = c.MergeArea.Height
                    Selection.ShapeRange.Width = c.MergeArea.Width
                    Selection.ShapeRange.Top = c.MergeArea.Top
                    Selection.ShapeRange.Left = c.MergeArea.Left
bc3:                On Error GoTo 0
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing
            End If
        End With
    Next sh
End Sub

Sub Div1000(nDigit As Integer)
Dim FindFormat As String, ReplaceFormat As String, c As Range, lcValue As Variant, _
    firstAddress As String, old_sh As Object
    Set old_sh = ActiveSheet
    FindFormat = "# ##0,00"
    If nDigit > 0 Then
        ReplaceFormat = "# ##0," + String(nDigit, "0")
    Else
        ReplaceFormat = "# ##0"
    End If
    Application.FindFormat.NumberFormatLocal = FindFormat
    For Each sh In ActiveWorkbook.Sheets
        sh.Select
        With ActiveSheet.Cells
            sh.Cells(1, 1).Select
            Set c = .Find(what:="*", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, _
                        SearchOrder:=xlByRows, SearchDirection:=xlNext, SearchFormat:=True)
            If Not c Is Nothing Then
                firstAddress = c.Address
                Do
                    lcValue = c.Value
                    If IsNumeric(lcValue) Then
                        lcValue = lcValue / 1000
                        c.Value = lcValue
                        If ReplaceFormat <> "" Then c.NumberFormatLocal = ReplaceFormat
                    End If
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And firstAddress <> c.Address
            End If
        End With
    Next sh
    old_sh.Select
End Sub

Function ДОБАВИТЬДНИ(dt As Date, k As Integer) As Date
   ДОБАВИТЬДНИ = dt + k
End Function

Sub SetPrintArea()
Dim rLast As Range, LastCell As Range
    Set rLast = Cells.SpecialCells(xlLastCell)
    If rLast.Cells(1, 1).Value = "" Then
        On Error Resume Next
        Set LastCell = Cells(Cells.Find("*", rLast, xlFormulas, , xlByRows, xlPrevious).row, Cells.Find("*", rLast, xlFormulas, , xlByColumns, xlPrevious).Column)
        If Err.Number <> 0 Then Set LastCell = r.Parent.Cells(1, 1)
        On Error GoTo 0
        Set rLast = LastCell
    End If
    On Error Resume Next
    ActiveSheet.PageSetup.PrintArea = Range(Cells(1, 1), rLast.MergeArea).EntireColumn.Address
    On Error GoTo 0
End Sub

Sub CreateHB()
Dim c As Range
    For Each sh In ActiveWorkbook.Sheets
        sh.Select
        With ActiveSheet.Cells
            Set c = .Find(what:="#HB", LookIn:=xlValues, LookAt:=xlPart)
            If Not c Is Nothing Then
                Do
                    ActiveSheet.HPageBreaks.Add Before:=c
                    c.Value = ""
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing
            End If
        End With
    Next sh
End Sub

Function StrReplace(ByVal cWhere As String, ByVal cWhat As String, ByVal cRepl As String) As String
Dim n As Integer
    n = 1
    Do
        n = InStr(n, cWhere, cWhat)
        If n > 0 Then
            cWhere = Mid(cWhere, 1, n - 1) + cRepl + Mid(cWhere, n + Len(cWhat))
            n = n + Len(cRepl)
        End If
    Loop While n <> 0
    StrReplace = cWhere
End Function

Sub InitPrintCBR()
    ' Удаляем старую панель
    Call DeletePrintCBR("Печать")
    ' Добавляем новую панель
    Application.CommandBars.Add(Name:="Печать", Position:=msoBarTop, Temporary:=True).Visible = True
    Application.CommandBars("Печать").Controls.Add Type:=msoControlButton, Id:= _
        109, Before:=1
    With Application.CommandBars("Печать").Controls.Add(Type:=msoControlButton, Id:= _
        2521, Before:=2)
        .Caption = "Печать текущего документа"
    End With
    With Application.CommandBars("Печать").Controls.Add(Type:=msoControlButton, _
        Before:=3)
        .FaceId = 160
        .Style = msoButtonIcon
        .Caption = "Печать всех документов"
        .OnAction = "PrintAllSheets"
    End With
End Sub

Sub DeletePrintCBR(cbrname As String)
Dim Found As Boolean, cbar As Object
    Found = False
    For Each cbar In Application.CommandBars
        If cbar.Name = cbrname Then Found = True
    Next
    If Found Then Application.CommandBars(cbrname).Delete
    Set cbar = Nothing
End Sub

Sub PrintAllSheets()
Dim ws As Object
    For Each ws In Application.ActiveWorkbook.Worksheets
        ws.PrintOut
    Next ws
    Set ws = Nothing
End Sub

Sub CreateAutoFilter(s As String)
    Dim oSheet As Worksheet, oCom As Comment, oStart As Range, oEnd As Range, aSplit() As String _
        , nShiftRow As Long, nShiftCol As Long
    
    For Each oSheet In Application.ActiveWorkbook.Worksheets
        Set oStart = Nothing
        Set oEnd = Nothing
        
        If oSheet.Name <> "Service" And oSheet.Name <> "Данные" And oSheet.Name <> "Документ" Then
            For Each oCom In oSheet.Comments
                If VBA.Trim(oCom.Text) <> "" Then
                    aSplit = VBA.Split(VBA.Trim(oCom.Text), "#")
                    nShiftRow = 0
                    If UBound(aSplit, 1) > 0 Then
                        nShiftRow = VBA.Val(aSplit(1))
                    End If
                    nShiftCol = 0
                    If UBound(aSplit, 1) > 1 Then
                        nShiftCol = VBA.Val(aSplit(2))
                    End If
                    
                    Select Case VBA.Trim(aSplit(0))
                    Case "AutoFilterStart"
                        Set oStart = oSheet.Cells(oCom.Parent.Cells(1, 1).row + nShiftRow, oCom.Parent.Cells(1, 1).Column + nShiftCol)
                        oCom.Parent.ClearComments
                    Case "AutoFilterEnd"
                        Set oEnd = oSheet.Cells(oCom.Parent.Cells(1, 1).row + nShiftRow, oCom.Parent.Cells(1, 1).Column + nShiftCol)
                        oCom.Parent.ClearComments
                    End Select
                End If
            Next oCom
        End If
        
        If Not oStart Is Nothing And Not oEnd Is Nothing Then
            If oStart.Cells(1, 1).row <= oEnd.Cells(1, 1).row And oStart.Cells(1, 1).Column <= oEnd.Cells(1, 1).Column Then
                oSheet.Activate
                oSheet.Range(oStart.Address + ":" + oEnd.Address).Select
                Selection.AutoFilter
                oStart.Select
            End If
        End If
    Next oSheet
End Sub

Function СУММСТР(r As Range, cSep As String) As String
Dim cRes As String, i As Long, cVal As String
    cRes = ""
    For i = 1 To r.Rows.Count
        cVal = r.Cells(i, 1).Value
        If Len(cVal) > 0 Then
            cRes = cRes & IIf(Len(cRes) > 0, cSep, "") & cVal
        End If
    Next i
    СУММСТР = cRes
End Function

Sub BookAutoFit(s As String)
    Dim oSheet As Worksheet, oCom As Comment, nStartRowFit As Long, nEndRowFit As Long
    
    On Error GoTo doError
    
    For Each oSheet In Application.ActiveWorkbook.Worksheets
        nStartRowFit = 0
        nEndRowFit = 0
        
        If oSheet.Visible = -1 And oSheet.Name <> "Service" And oSheet.Name <> "Данные" And oSheet.Name <> "Документ" Then
            For Each oCom In oSheet.Comments
                If VBA.Trim(oCom.Text) <> "" Then
                    Select Case VBA.Trim(oCom.Text)
                    Case "AutoFitStart"
                        nStartRowFit = oCom.Parent.Cells(1, 1).Row
                        oCom.Parent.ClearComments
                    Case "AutoFitEnd"
                        nEndRowFit = oCom.Parent.Cells(1, 1).Row
                        oCom.Parent.ClearComments
                    End Select
                End If
            Next oCom
            
            If nStartRowFit = 0 Then
                If oSheet.PageSetup.PrintTitleRows <> "" Then
                    nStartRowFit = oSheet.Range(oSheet.PageSetup.PrintTitleRows).Cells(1, 1).Row + _
                                   oSheet.Range(oSheet.PageSetup.PrintTitleRows).Rows.Count
                End If
            End If
            
            If nStartRowFit = 0 Then nStartRowFit = 1
            If nEndRowFit = 0 Then nEndRowFit = oSheet.Cells.Rows.Count
            
            If nStartRowFit <= nEndRowFit Then
                Call oSheet.Rows(nStartRowFit & ":" & nEndRowFit).EntireRow.AutoFit
            End If
        End If
    Next oSheet
    
doError:
End Sub

Function ВСПИСКЕ(Var As Variant, ParamArray OtherArgs()) As Variant
Dim bRet As Boolean, i As Integer
    bRet = False
    For i = LBound(OtherArgs()) To UBound(OtherArgs())
        bRet = bRet Or (Var = OtherArgs(i))
    Next i
    ВСПИСКЕ = bRet
End Function

