Sub Auto_Open()
On Error Resume Next
With ActiveSheet.PageSetup
.LeftMargin = Application.CentimetersToPoints(1)
.RightMargin = Application.CentimetersToPoints(1)
.TopMargin = Application.CentimetersToPoints(2)
.BottomMargin = Application.CentimetersToPoints(1)
.HeaderMargin = Application.CentimetersToPoints(2)
.FooterMargin = Application.CentimetersToPoints(1)
.Orientation = xlLandscape
.PaperSize = xlPaperA4
End With
Application.Visible = True
Application.CalculateFull ' MVV.20131212 : added.
End Sub
Function GetSeparator() As String
Application.Volatile
GetSeparator = Application.International(xlDecimalSeparator)
End Function
Function СУММПРОИЗВЕСЛИ(rashod As Double, flags As Range, Flag As String, vals1 As Range, vals2 As Range, nIndent As Integer) As Double
Application.Volatile
Dim rez As Double
Dim Count As Double
Dim I As Long
Dim valA As Double
Dim valB As Double
rez = 0
Count = flags.Rows.Count
If Count > vals1.Rows.Count Then
Count = vals1.Rows.Count
End If
If Count > vals2.Rows.Count Then
Count = vals2.Rows.Count
End If
For I = 1 To Count
If flags.Cells(I, 1).Value = Flag Then
If (vals1.Cells(I, 1) = "") Then
valA = 0
Else
valA = vals1.Cells(I, 1)
End If
If (vals2.Cells(I + nIndent, 1) = "") Then
valB = 0
Else
valB = vals2.Cells(I + nIndent, 1)
End If
rez = rez + valA * valB * rashod
End If
Next I
СУММПРОИЗВЕСЛИ = rez
End Function
Function СУММПРОИЗВЕСЛИ2(rashod As Double, flags1 As Range, Flag1 As String, flags2 As Range, Flag2 As String, vals1 As Range, vals2 As Range, nIndent As Integer) As Double
Application.Volatile
Dim rez As Double
Dim Count As Double
Dim I As Long
Dim valA As Double
Dim valB As Double
Dim tmp As String
rez = 0
Count = flags1.Rows.Count
If Count > vals1.Rows.Count Then
Count = vals1.Rows.Count
End If
If Count > vals2.Rows.Count Then
Count = vals2.Rows.Count
End If
For I = 1 To Count
If flags1.Cells(I, 1).Value = Flag1 And flags2.Cells(I, 1).Value = Flag2 Then
tmp = vals1.Cells(I, 1).Value
If (tmp = "") Then
valA = 0
Else
valA = CDbl(tmp)
End If
tmp = vals2.Cells(I + nIndent, 1).Value
If (tmp = "") Then
valB = 0
Else
valB = CDbl(tmp)
End If
rez = rez + valA * valB * rashod
End If
Next I
СУММПРОИЗВЕСЛИ2 = rez
End Function
Function СУММПРОИЗВЕСЛИ2ИЛИ(rashod As Double, flags1 As Range, Flag1 As String, flags2 As Range, Flag2 As String, vals1 As Range, vals2 As Range, nIndent As Integer) As Double
Application.Volatile
Dim rez As Double
Dim Count As Double
Dim I As Long
Dim valA As Double
Dim valB As Double
Dim tmp As String
rez = 0
Count = flags1.Rows.Count
If Count > vals1.Rows.Count Then
Count = vals1.Rows.Count
End If
If Count > vals2.Rows.Count Then
Count = vals2.Rows.Count
End If
For I = 1 To Count
If flags1.Cells(I, 1).Value = Flag1 Or flags2.Cells(I, 1).Value = Flag2 Then
tmp = vals1.Cells(I, 1).Value
If (tmp = "") Then
valA = 0
Else
valA = CDbl(tmp)
End If
tmp = vals2.Cells(I + nIndent, 1).Value
If (tmp = "") Then
valB = 0
Else
valB = CDbl(tmp)
End If
rez = rez + valA * valB * rashod
End If
Next I
СУММПРОИЗВЕСЛИ2ИЛИ = rez
End Function
Function СУММКОЭФПРОЦЕНТЕСЛИ(koef As Double, percent As Double, flags As Range, Flag As String, vals As Range, nIndent As Integer) As Double
Application.Volatile
Dim rez As Double
Dim Count As Double
Dim I As Long
Dim dbSto As Double
dbSto = 100
rez = 0
Count = flags.Rows.Count
If Count > vals.Rows.Count Then
Count = vals.Rows.Count
End If
For I = 1 To Count
If flags.Cells(I, 1).Value = Flag Then
rez = rez + vals.Cells(I + nIndent, 1) * koef * percent / dbSto
End If
Next I
СУММКОЭФПРОЦЕНТЕСЛИ = rez
End Function
Function СУММЕСЛИ2(flags1 As Range, Flag1 As String, flags2 As Range, Flag2 As String, vals As Range) As Double
Application.Volatile
Dim rez As Double
Dim Count As Double
Dim I As Long
Dim tmp As String
Count = flags1.Rows.Count
If Count > flags2.Rows.Count Then
Count = flags2.Rows.Count
End If
If Count > vals.Rows.Count Then
Count = vals.Rows.Count
End If
rez = 0
For I = 1 To Count
If flags1.Cells(I, 1).Value = Flag1 And flags2.Cells(I, 1).Value = Flag2 Then
tmp = vals.Cells(I, 1).Value
If (tmp = "" Or tmp = " ") Then
tmp = "0"
End If
rez = rez + CDbl(tmp) 'vals.Cells(i, 1)
End If
Next I
СУММЕСЛИ2 = rez
End Function
Function СУММЕСЛИНЕ2(flags1 As Range, ValueNe1 As Double, flags2 As Range, ValueNe2 As Double, vals As Range) As Double
Application.Volatile
Dim rez As Double
Dim Count As Double
Dim I As Long
Count = flags1.Rows.Count
If Count > flags2.Rows.Count Then
Count = flags2.Rows.Count
End If
If Count > vals.Rows.Count Then
Count = vals.Rows.Count
End If
rez = 0
For I = 1 To Count
If flags1.Cells(I, 1).Value <> ValueNe1 And flags2.Cells(I, 1).Value <> ValueNe2 Then
rez = rez + vals.Cells(I, 1)
End If
Next I
СУММЕСЛИНЕ2 = rez
End Function
Function СУММЕСЛИДА1НЕ1(flags1 As Range, ValueDa As String, flags2 As Range, ValueNe As String, vals As Range) As Double
Application.Volatile
Dim rez As Double
Dim Count As Double
Dim I As Long
Count = flags1.Rows.Count
If Count > flags2.Rows.Count Then
Count = flags2.Rows.Count
End If
If Count > vals.Rows.Count Then
Count = vals.Rows.Count
End If
rez = 0
For I = 1 To Count
If flags1.Cells(I, 1).Value = ValueDa Then
If ValueNe <> "0" And flags2.Cells(I, 1).Value <> ValueNe Then
rez = rez + vals.Cells(I, 1)
ElseIf ValueNe = "0" And Trim(flags2.Cells(I, 1).Value) <> "0" And Trim(flags2.Cells(I, 1).Value) <> "" Then
rez = rez + vals.Cells(I, 1)
End If
End If
Next I
СУММЕСЛИДА1НЕ1 = rez
End Function
Function СУММЕСЛИ3(flags1 As Range, Flag1 As String, flags2 As Range, Flag2 As String, flags3 As Range, Flag3 As String, vals As Range) As Double
Application.Volatile
Dim rez As Double
Dim Count As Double
Dim I As Long
Count = flags1.Rows.Count
If Count > flags2.Rows.Count Then
Count = flags2.Rows.Count
End If
If Count > flags3.Rows.Count Then
Count = flags3.Rows.Count
End If
If Count > vals.Rows.Count Then
Count = vals.Rows.Count
End If
rez = 0
For I = 1 To Count
If flags1.Cells(I, 1).Value = Flag1 And flags2.Cells(I, 1).Value = Flag2 And flags3.Cells(I, 1).Value = Flag3 Then
rez = rez + vals.Cells(I, 1)
End If
Next I
СУММЕСЛИ3 = rez
End Function
Function ТРАНСПРАСХОД(Opred0 As Range, Opred6 As Range, Opred7 As Range, Prices As Range, Nachis25 As Range, Nachis26 As Range) As Double
Application.Volatile
Dim rez As Double
Dim Count As Double
Dim I As Long
Dim dbSto As Double
dbSto = 100
Count = Opred0.Rows.Count
If Count > Opred6.Rows.Count Then
Count = Opred6.Rows.Count
End If
If Count > Opred7.Rows.Count Then
Count = Opred7.Rows.Count
End If
If Count > Prices.Rows.Count Then
Count = Prices.Rows.Count
End If
If Count > Nachis25.Rows.Count Then
Count = Nachis25.Rows.Count
End If
If Count > Nachis26.Rows.Count Then
Count = Nachis26.Rows.Count
End If
rez = 0
For I = 1 To Count
If Opred7.Cells(I, 1).Value = " " Then
If Opred0.Cells(I, 1).Value = " " And Opred6.Cells(I, 1).Value = "1" Then
rez = rez + Prices.Cells(I, 1) * Nachis25.Cells(I, 1) / dbSto
ElseIf Opred6.Cells(I, 1).Value = "2" Then
rez = rez + Prices.Cells(I, 1) * Nachis26.Cells(I, 1)
End If
End If
Next I
ТРАНСПРАСХОД = rez
End Function
Function ЗАГОТСКЛАДРАСХОД(Opred0 As Range, Opred6 As Range, Opred7 As Range, Prices As Range, Nachis23 As Range, Nachis24 As Range, Nachis25 As Range, Nachis26 As Range, Nachis27 As Range, Nachis28 As Range, Nachis31 As Range) As Double
Application.Volatile
Dim Norma As Double
Dim rez As Double
Dim Count As Double
Dim I As Long
Dim dbSto As Double
dbSto = 100
Count = Opred0.Rows.Count
If Count > Opred6.Rows.Count Then
Count = Opred6.Rows.Count
End If
If Count > Opred7.Rows.Count Then
Count = Opred7.Rows.Count
End If
If Count > Prices.Rows.Count Then
Count = Prices.Rows.Count
End If
If Count > Nachis23.Rows.Count Then
Count = Nachis23.Rows.Count
End If
If Count > Nachis24.Rows.Count Then
Count = Nachis24.Rows.Count
End If
If Count > Nachis25.Rows.Count Then
Count = Nachis25.Rows.Count
End If
If Count > Nachis26.Rows.Count Then
Count = Nachis26.Rows.Count
End If
If Count > Nachis27.Rows.Count Then
Count = Nachis27.Rows.Count
End If
If Count > Nachis28.Rows.Count Then
Count = Nachis28.Rows.Count
End If
If Count > Nachis31.Rows.Count Then
Count = Nachis31.Rows.Count
End If
rez = 0
For I = 1 To Count
If Opred7.Cells(I, 1).Value = " " Then
Norma = Prices.Cells(I, 1)
Norma = Norma + Prices.Cells(I, 1) * Nachis23.Cells(I, 1) / dbSto
Norma = Norma + Prices.Cells(I, 1) * Nachis24.Cells(I, 1) / dbSto
If Opred0.Cells(I, 1).Value = " " And Opred6.Cells(I, 1).Value = "1" Then
Norma = Norma + Prices.Cells(I, 1) * Nachis25.Cells(I, 1) / dbSto
ElseIf Opred6.Cells(I, 1).Value = "2" Then
Norma = Norma + Prices.Cells(I, 1) * Nachis26.Cells(I, 1)
End If
Norma = Norma + Prices.Cells(I, 1) * Nachis28.Cells(I, 1) / dbSto
Norma = Norma + Prices.Cells(I, 1) * Nachis31.Cells(I, 1) / dbSto
rez = rez + Norma * Nachis27.Cells(I, 1) / dbSto
End If
Next I
ЗАГОТСКЛАДРАСХОД = rez
End Function
Function ОКРУГЛВСЕ(val As Double, signs As Long) As Double
Dim res As Double
Dim intsigns As Long
If val = 0 Then
ОКРУГЛВСЕ = 0
Exit Function
End If
sign = Sgn(val)
valpos = val * sign
dint = Int(valpos)
If dint > 0 Then
intsigns = 0
While dint >= 1 ' MVV.20130117 : Old: >
intsigns = intsigns + 1
dint = dint / 10
Wend
If signs < intsigns Then
signs = 0
Else
signs = signs - intsigns
End If
ElseIf signs > 0 Then
signs = signs - 1
End If
valpos = WorksheetFunction.Round(valpos, signs)
ОКРУГЛВСЕ = valpos * sign
End Function
Function ПОЛУЧШИФР(shifr As String, fUpperCase As Boolean) As String
Application.Volatile
Dim first As String
first = Left(shifr, 1)
If fUpperCase = 0 Then ' lower case
first = LCase(first)
Else
first = UCase(first)
End If
ПОЛУЧШИФР = first & Mid(shifr, 2)
End Function
Function ПОЛУЧКОНЗЗНАЧ(Naim As String) As Double
Application.Volatile
Dim first As String
lPosA = InStr(Naim, "=")
If lPosA = 0 Or lPosA = Null Then
ПОЛУЧКОНЗЗНАЧ = 0
Exit Function
End If
sTrail = Trim(Mid(Naim, lPosA + 1, Len(Naim)))
lPosB = InStr(sTrail, " ")
If lPosB = 0 Or lPosB = Null Then
lPosB = InStr(sTrail, ")")
If lPosB = 0 Or lPosB = Null Then
lPosB = Len(sTrail) + 1
End If
End If
If lPosB < 2 Then
ПОЛУЧКОНЗЗНАЧ = 0
Exit Function
End If
'CDbl Val
ПОЛУЧКОНЗЗНАЧ = CDbl(Trim(Left(sTrail, lPosB - 1)))
End Function
Function ФОРМУЛАВОЗВРАТБАЗ(V As Range, Poprav As String, Znach As String)
Application.Volatile
Dim retVal As String
Dim TmpStr As String
retVal = "'=("
If Poprav <> "0" Then
retVal = retVal + Poprav
End If
If Znach <> "" Then
retVal = retVal + Znach
End If
TmpStr = V.Value
retVal = retVal + ") * " + TmpStr
ФОРМУЛАВОЗВРАТБАЗ = retVal
End Function
Function ФОРМУЛАВОЗВРАТТЕК(V As Range, Poprav As String, Znach As String, KoefPop As Range)
Application.Volatile
Dim retVal As String
Dim TmpStr As String
retVal = "'=("
If Poprav <> "0" Then
retVal = retVal + Poprav
End If
If Znach <> "" Then
retVal = retVal + Znach
End If
TmpStr = V.Value
retVal = retVal + ") * " + TmpStr
If IsNull(KoefPop) = False Then
TmpStr = KoefPop.Value
If TmpStr <> "" Then
retVal = retVal + " * " + TmpStr
End If
End If
ФОРМУЛАВОЗВРАТТЕК = retVal
End Function
' ========================================================================
' ======= MVV.20130129 : Header Revision : Function ЧИСЛОВТЕКСТ() ========
' ========================================================================
Private Function TriadRubText(ByVal sTriad As String) As String
If Trim$(sTriad) = vbNullString Then Exit Function
If Mid$(sTriad, 2, 1) <> "1" Then
Select Case Mid$(sTriad, 3, 1)
Case "1"
TriadRubText = "рубль"
Case "2", "3", "4"
TriadRubText = "рубля"
Case Else
TriadRubText = "рублей"
End Select
Else
TriadRubText = "рублей"
End If
End Function
Private Function Triad2Text(ByVal sTriad As String, ByVal tn As Byte) As String
Dim sotni, dubl, des, ed, edj, ind, aRub
Dim sResult As String, Post As String
If val(sTriad) = 0 Then Exit Function
sotni = Array("сто", "двести", "триста", "четыреста", "пятьсот", "шестьсот", "семьсот", "восемьсот", "девятьсот")
dubl = Array("десять", "одиннадцать", "двенадцать", "тринадцать", "четырнадцать", _
"пятнадцать", "шестнадцать", "семнадцать", "восемнадцать", "девятнадцать")
des = Array("двадцать", "тридцать", "сорок", "пятьдесят", "шестьдесят", "семьдесят", "восемьдесят", "девяносто")
ed = Array("один", "два", "три", "четыре", "пять", "шесть", "семь", "восемь", "девять")
edj = Array("одна", "две", "три", "четыре", "пять", "шесть", "семь", "восемь", "девять")
ind = Array("", " тысяч", " миллион", " миллиард", " триллион", " квадриллион", " квинтиллион")
aRub = Array("рубль", "рубля", "рубля", "рубля", "рублей", "рублей", "рублей", "рублей", "рублей")
If Mid$(sTriad, 1, 1) <> "0" Then
sResult = sResult + sotni(CByte(Mid$(sTriad, 1, 1)) - 1)
End If
If Mid$(sTriad, 2, 1) = "1" Then
sResult = sResult + " " + dubl(CByte(Mid$(sTriad, 3, 1)))
ElseIf Mid$(sTriad, 2, 1) <> "0" Then
sResult = sResult + " " + des(CByte(Mid$(sTriad, 2, 1)) - 2)
End If
If Mid$(sTriad, 3, 1) <> "0" And Mid$(sTriad, 2, 1) <> "1" Then
If tn = 1 Then
sResult = sResult + " " + edj(CByte(Mid$(sTriad, 3, 1)) - 1)
Else ' tn <> 1
sResult = sResult + " " + ed(CByte(Mid$(sTriad, 3, 1)) - 1)
End If
End If
If tn > 0 Then
If Mid$(sTriad, 2, 1) <> "1" Then
Select Case tn
Case 1
Select Case Mid$(sTriad, 3, 1)
Case "1"
Post = ind(tn) + "а"
Case "2"
Post = ind(tn) + "и"
Case "3"
Post = ind(tn) + "и"
Case "4"
Post = ind(tn) + "и"
Case Else
Post = ind(tn) + ""
End Select
Case 2, 3, 4
Select Case Mid$(sTriad, 3, 1)
Case "1"
Post = ind(tn) + ""
Case "2"
Post = ind(tn) + "а"
Case "3"
Post = ind(tn) + "а"
Case "4"
Post = ind(tn) + "а"
Case Else
Post = ind(tn) + "ов"
End Select
End Select
Else
Select Case tn
Case 1
Post = ind(tn)
Case Else
Post = ind(tn) + "ов"
End Select
End If ' Mid$(sTriad, 2, 1) <> "1"
End If ' tn > 0
Triad2Text = Trim$(sResult) + Post
End Function
Private Function Kop2Text(ByVal sKop As String, Optional bShowAlways As Boolean = False) As String
Dim dubl, des, ed, aEdIzm
Dim sEdIzm As String, sResult As String
sKop = Replace$(sKop, " ", "") ' Убрать пробелы.
If Not IsNumeric(sKop) Then Exit Function
Do While Len(sKop) > 2
sKop = Left$(sKop, Len(sKop) - 1)
Loop
If CDbl(sKop) = 0 Then
Kop2Text = IIf(bShowAlways, "00 копеек", "")
Exit Function
End If
sKop = sKop + String$(2 - Len(sKop), "0")
dubl = Array("десять", "одиннадцать", "двенадцать", "тринадцать", "четырнадцать", _
"пятнадцать", "шестнадцать", "семнадцать", "восемнадцать", "девятнадцать")
des = Array("двадцать", "тридцать", "сорок", "пятьдесят", "шестьдесят", "семьдесят", "восемьдесят", "девяносто")
ed = Array("одна", "две", "три", "четыре", "пять", "шесть", "семь", "восемь", "девять")
aEdIzm = Array("копейка", "копейки", "копейки", "копейки", "копеек", "копеек", "копеек", "копеек", "копеек")
sEdIzm = "копеек"
If Mid$(sKop, 1, 1) = "1" Then
sResult = sResult + " " + dubl(CByte(Mid$(sKop, 2, 1)))
ElseIf Mid$(sKop, 1, 1) <> "0" Then
sResult = sResult + " " + des(CByte(Mid$(sKop, 1, 1)) - 2)
End If
If Mid$(sKop, 2, 1) <> "0" And Mid$(sKop, 1, 1) <> "1" Then
sResult = sResult + " " + ed(CByte(Mid$(sKop, 2, 1)) - 1)
sEdIzm = aEdIzm(CByte(Mid$(sKop, 2, 1)) - 1)
End If
Kop2Text = Trim$(sResult) + " " + sEdIzm
End Function
Function ЧИСЛОВТЕКСТ(ByVal vNumber As Variant, Optional ByVal bShowKopAlways As Boolean = False) As String
Dim fVal As Double, sVal As String, sSign As String
Dim asIntFrac() As String, asTriads() As String
Dim sResult As String
Dim I As Byte
If IsEmpty(vNumber) Then Exit Function
Select Case VarType(vNumber)
Case vbByte, vbInteger, vbLong, vbSingle, vbDouble, vbDecimal, vbCurrency
fVal = vNumber
sVal = CStr(fVal)
Case vbString
vNumber = Replace(vNumber, " ", "") ' Убрать пробелы.
' Сделать разделитель корректным.
vNumber = Replace(vNumber, ".", Application.DecimalSeparator)
vNumber = Replace(vNumber, ",", Application.DecimalSeparator)
If Not IsNumeric(vNumber) Then Exit Function
fVal = CDbl(vNumber)
sVal = vNumber
Case Else
Exit Function
End Select
If fVal < 0 Then
fVal = -fVal
sVal = Replace$(sVal, "-", "")
sSign = "минус "
End If
' Получить из строкового представления дробную часть числа.
asIntFrac = Split(sVal, Application.DecimalSeparator)
' Представить целую часть числа в виде строки, разбитой на триады.
sVal = Format$(Fix(fVal), "#,##0")
' Разбить на триады.
asTriads = Split(sVal, Application.ThousandsSeparator)
' Дополнить старшую триаду 0-ми слева до полных трех символов.
asTriads(0) = String$(3 - Len(asTriads(0)), "0") + asTriads(0)
' Перевести в текст потриадно.
For I = LBound(asTriads) To UBound(asTriads)
sVal = Triad2Text(asTriads(I), UBound(asTriads) - I)
If sVal <> vbNullString Then sResult = sResult + sVal + " "
Next
sResult = Trim$(sResult)
' Присовокупить денежную единицу в правильных падеже и числе.
If sResult <> vbNullString Then
sResult = sResult + " " + TriadRubText(asTriads(UBound(asTriads)))
End If
' Перевести дробную часть в текст включая сотые денежной единицы.
If UBound(asIntFrac) > 0 Then
sResult = sResult + " " + Kop2Text(asIntFrac(1), bShowKopAlways)
ElseIf bShowKopAlways Then
sResult = sResult + " 00 копеек"
End If
sResult = Trim$(sResult)
ЧИСЛОВТЕКСТ = sSign + UCase$(Mid$(sResult, 1, 1)) + Mid$(sResult, 2)
End Function
Function ВЫЧИСЛ(R As Range)
ВЫЧИСЛ = Application.Evaluate(Replace(R.Value, ",", "."))
End Function |