проверить и исправит расчеты не нарушая саму архитектуру. Окраску ячеек границы таблицы. Private Sub ToggleButton13_Click()
If Me.ToggleButton13.Value = False Then Exit Sub
Me.ToggleButton13.Value = False
Dim wsBase As Worksheet, wsInput As Worksheet, wsSal As Worksheet
Dim lastRow As Long, targetRow As Long, i As Long, c As Long, d As Long, s As Integer
Dim managerName As String, accountantName As String, startDate As Date, endDate As Date
Dim groupName As String, vCol As Variant, cols As Variant
Dim currentDate As Date, isHoliday As Boolean, dailyHours As Double
Dim sickDays As Long, vacDays As Long, sickPay As Double, vacPay As Double
Dim empExperience As Variant, kExperience As Double, cellVal As String
Dim rate As Double, planHours As Double, salarySum As Double
Dim rowHolidayHours As Double, rowWeekdayOvertime As Double
Dim daysDetail As String, dayAbbr As String
' --- БЛОК НАСТРОЕК ---
Dim nonWorkCodes As String, deductCodes As String
nonWorkCodes = "обс,пг,ог,до,у,к"
deductCodes = "обс,пг"
On Error Resume Next
Set wsBase = ThisWorkbook.Sheets("База")
Set wsInput = ThisWorkbook.Sheets("форма_ввода")
On Error GoTo 0
If wsBase Is Nothing Or wsInput Is Nothing Then
MsgBox "Ошибка: Листы 'База' или 'форма_ввода' не найдены!": Exit Sub
End If
managerName = InputBox("Введите ФИО ответственного:", "Подпись", "Иванова Н.В.")
accountantName = InputBox("Введите ФИО бухгалтера:", "Подпись", "Петрова А.С.")
On Error Resume Next
startDate = CDate(InputBox("Начальная дата (ДД.ММ.ГГГГ):", "Период", "01.02.2026"))
endDate = CDate(InputBox("Конечная дата (ДД.ММ.ГГГГ):", "Период", "28.02.2026"))
On Error GoTo 0
If startDate = 0 Then Exit Sub
Set wsSal = ThisWorkbook.Sheets("Начисления")
If wsSal Is Nothing Then
Set wsSal = ThisWorkbook.Sheets.Add(After:=wsBase): wsSal.Name = "Начисления"
End If
Application.ScreenUpdating = False
With wsSal
' Сохранение коэффициентов
Dim vNDFL As Double, vP15 As Double, vP20 As Double, vVP20 As Double, vNight As Double
vP15 = .Range("Q5").Value: vP20 = .Range("R5").Value: vVP20 = .Range("S5").Value
vNight = .Range("T5").Value: vNDFL = .Range("U5").Value
Application.DisplayAlerts = False
.Cells.UnMerge: .Rows("6:" & .Rows.Count).Clear
Application.DisplayAlerts = True
' Шапка (теперь до AG - 33 столбца)
.Range("A1:AG1").Merge: .Range("A1").Value = "ТЕСТОВАЯ КОМПАНИЯ": .Range("A1").Font.Bold = True: .Range("A1").HorizontalAlignment = xlCenter
.Range("A2:AG2").Merge: .Range("A2").Value = "Начисление зарплаты за период с " & Format(startDate, "dd.mm.yyyy") & " по " & Format(endDate, "dd.mm.yyyy")
.Range("A2").Font.Color = vbRed: .Range("A2").HorizontalAlignment = xlCenter: .Range("A2").Font.Bold = True
With .Range("P4:P5"): .Merge: .Value = "Коэф=>": .Font.Bold = True: .HorizontalAlignment = xlRight: End With
.Range("Q4:U4").Value = Array("перераб 1.5", "перераб 2.0", "вых/празд 2.0", "Над. Ночь", "НДФЛ")
.Range("Q5").Value = IIf(vP15 <= 0, 1.5, vP15): .Range("R5").Value = IIf(vP20 <= 0, 2#, vP20)
.Range("S5").Value = IIf(vVP20 <= 0, 2#, vVP20): .Range("T5").Value = IIf(vNight <= 0, 40, vNight): .Range("U5").Value = IIf(vNDFL <= 0, 0.13, vNDFL)
.Range("P4:U5").Borders.LineStyle = xlContinuous: .Range("P4:U5").Borders.Weight = xlMedium
' Цветные блоки (Добавлен AG в последний блок)
Dim rngs, clrs, idx As Integer
rngs = Array("K6:L7", "M6:N7", "O6:S7", "T6:W7", "X6:AA7", "AB6:AE7", "AF6:AG7")
clrs = Array(RGB(221, 235, 247), RGB(221, 235, 247), RGB(226, 239, 218), RGB(255, 242, 204), RGB(228, 242, 213), RGB(242, 220, 219), RGB(255, 255, 153))
For idx = 0 To UBound(rngs)
With .Range(rngs(idx))
.Merge: .Interior.Color = clrs(idx): .Font.Bold = True: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter: .Borders.LineStyle = xlContinuous: .Borders.Weight = xlMedium
End With
Next idx
.Range("K6").Value = "По графику": .Range("M6").Value = "Переработка": .Range("O6").Value = "Учет переработок"
.Range("T6").Value = "Расчет зар. платы": .Range("X6").Value = "Начисления": .Range("AB6").Value = "Удержания": .Range("AF6").Value = "Выплаты"
' Подписи колонок 1-10
Dim h1: h1 = Array("Н/П", "Таб. №", "Сотрудник (Ф.И.О)", "должность", "оплата", "сумма (руб)", "норм.дн/ч", "план.дн", "час/мес", "Время работы")
For c = 1 To 10
With .Range(.Cells(6, c), .Cells(8, c))
.Merge: .Value = h1(c - 1): .Interior.Color = RGB(255, 255, 204): .Font.Bold = True: .Borders.LineStyle = xlContinuous: .Borders.Weight = xlMedium: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter: .WrapText = True
End With
Next c
' Подписи колонок 11-33 (Добавлен AG - надбавка 2)
Dim hSub: hSub = Array("час(отр)", "дн(отр)", "часов", "дней", "баланс", "Какие дни", "1.5 (1-е 2ч)", "2.0 (след)", "вых./пр.", "З/П", "перераб", "больнич", "отпуск", "премия", "надбавка", "прочие", "НДФЛ", "штраф", "исп.лист", "удерж", "аванс", "К ВЫПЛАТЕ", "надбавка 2")
For idx = 0 To UBound(hSub)
With .Cells(8, idx + 11)
.Value = hSub(idx): .Borders.LineStyle = xlContinuous: .Borders.Weight = xlThin: .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter: .Font.Size = 8: .Font.Bold = True
End With
Next idx
End With
' --- ЦИКЛ ---
lastRow = wsBase.Cells(wsBase.Rows.Count, 3).End(xlUp).Row
targetRow = 9
' Список колонок для объединения (Добавлен 33)
cols = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 11, 12, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33)
For i = 7 To lastRow
If wsBase.Cells(i, 1).Interior.Color = RGB(217, 217, 217) Then
groupName = IIf(wsBase.Cells(i, 1).Value <> "", wsBase.Cells(i, 1).Value, wsBase.Cells(i, 3).Value)
With wsSal.Range("A" & targetRow & ":AG" & targetRow)
.Merge: .Value = groupName: .Font.Bold = True: .Interior.Color = RGB(217, 217, 217): .HorizontalAlignment = xlCenter: .Borders.LineStyle = xlContinuous: .Borders.Weight = xlMedium
End With
targetRow = targetRow + 1
ElseIf wsBase.Cells(i, 10).Value = "День" Then
planHours = val(wsBase.Cells(i, 9).Value): salarySum = val(wsBase.Cells(i, 6).Value)
rate = IIf(planHours > 0, salarySum / planHours, 0)
' Вычеты за прогулы
Dim missingDays As Long: missingDays = 0
For d = 11 To 41
cellVal = LCase(Trim(CStr(wsBase.Cells(i, d).Value)))
If InStr(deductCodes, cellVal) > 0 And cellVal <> "" Then missingDays = missingDays + 1
Next d
Dim planDaysNorm As Double: planDaysNorm = IIf(planHours > 0, planHours / 8, 1)
Dim actualSalary As Double: actualSalary = salarySum - ((salarySum / planDaysNorm) * missingDays)
' Больничные и отпуска
sickDays = 0: vacDays = 0
For s = 0 To 2
For d = 11 To 41
cellVal = LCase(Trim(CStr(wsBase.Cells(i + s, d).Value)))
If cellVal = "б" Then sickDays = sickDays + 1
If cellVal = "от" Then vacDays = vacDays + 1
Next d
Next s
If sickDays > 0 Then
empExperience = InputBox("Введите стаж сотрудника " & wsBase.Cells(i, 3).Value & ":", "Больничный",
kExperience = IIf(val(empExperience) >= 8, 1, IIf(val(empExperience) >= 5, 0.8, 0.6))
sickPay = Round((salarySum / 30) * kExperience * sickDays, 2)
Else: sickPay = 0: End If
vacPay = Round((salarySum / 29.3) * vacDays, 2)
wsSal.Range("A" & targetRow & ":H" & targetRow).Value = wsBase.Range("A" & i & ":H" & i).Value
wsSal.Range("K" & targetRow & ":L" & targetRow).Value = wsBase.Range("AP" & i & ":AQ" & i).Value
wsSal.Cells(targetRow, 10).Resize(3, 1).Value = Application.Transpose(Array("День", "Вечер", "Ночь"))
' Переработки по сменам
For s = 0 To 2
rowHolidayHours = 0: rowWeekdayOvertime = 0: daysDetail = ""
For d = 11 To 41
currentDate = DateSerial(Year(startDate), Month(startDate), d - 10)
If currentDate >= startDate And currentDate <= endDate Then
cellVal = LCase(Trim(CStr(wsBase.Cells(i + s, d).Value)))
isHoliday = (Weekday(currentDate, vbMonday) > 5) Or Not IsError(Application.Match(CLng(currentDate), wsInput.Range("AS7:AS47"), 0)) Or (cellVal = "пр")
dayAbbr = Choose(Weekday(currentDate, vbMonday), "Пн", "Вт", "Ср", "Чт", "Пт", "Сб", "Вс")
If IsNumeric(cellVal) And cellVal <> "" Then
dailyHours = CDbl(cellVal)
If isHoliday Then
rowHolidayHours = rowHolidayHours + dailyHours
daysDetail = daysDetail & "(" & Format(currentDate, "dd") & "," & dayAbbr & "," & dailyHours & ") "
Else
Dim ovt As Double: ovt = IIf(s = 0, IIf(dailyHours > 8, dailyHours - 8, 0), dailyHours)
rowWeekdayOvertime = rowWeekdayOvertime + ovt
If ovt > 0 Then daysDetail = daysDetail & "(" & Format(currentDate, "dd") & "," & dayAbbr & "," & ovt & ") "
End If
ElseIf InStr(nonWorkCodes, cellVal) > 0 And cellVal <> "" Then
daysDetail = daysDetail & "(" & Format(currentDate, "dd") & "," & dayAbbr & "," & UCase(cellVal) & ") "
End If
End If
Next d
Dim curR As Long: curR = targetRow + s
wsSal.Cells(curR, 13).Value = rowWeekdayOvertime + rowHolidayHours
wsSal.Cells(curR, 14).Value = (rowWeekdayOvertime + rowHolidayHours) / 8
wsSal.Cells(curR, 15).Value = rowWeekdayOvertime + rowHolidayHours
wsSal.Cells(curR, 16).Value = Trim(daysDetail)
wsSal.Cells(curR, 17).Value = Round(IIf(rowWeekdayOvertime > 2, 2, rowWeekdayOvertime) * rate * wsSal.Range("Q5").Value, 2)
wsSal.Cells(curR, 18).Value = Round(IIf(rowWeekdayOvertime > 2, rowWeekdayOvertime - 2, 0) * rate * wsSal.Range("R5").Value, 2)
wsSal.Cells(curR, 19).Value = Round(rowHolidayHours * rate * wsSal.Range("S5").Value, 2)
Next s
' Итоговые суммы
Dim r As Long: r = targetRow
wsSal.Cells(r, 9).Value = planHours
wsSal.Cells(r, 20).Value = Round(actualSalary, 2)
wsSal.Cells(r, 22).Value = sickPay
wsSal.Cells(r, 23).Value = vacPay
wsSal.Cells(r, 21).FormulaR1C1 = "=SUM(R[0]C[-4]:R[2]C[-2])"
Dim tSum As Double: tSum = val(wsSal.Cells(r, 20).Value) + val(wsSal.Cells(r, 21).Value) + val(wsSal.Cells(r, 22).Value) + val(wsSal.Cells(r, 23).Value)
wsSal.Cells(r, 27).Value = Round(tSum * wsSal.Range("U5").Value, 0)
wsSal.Cells(r, 32).FormulaR1C1 = "=SUM(RC20:RC26, RC33) - SUM(RC27:RC30) - RC31" ' Теперь включает RC33 (AG)
' Оформление
Application.DisplayAlerts = False
For Each vCol In cols
With wsSal.Range(wsSal.Cells(r, CInt(vCol)), wsSal.Cells(r + 2, CInt(vCol)))
.Merge: .VerticalAlignment = xlCenter: .HorizontalAlignment = xlCenter: .Borders.LineStyle = xlContinuous: .Borders.Weight = xlThin
End With
Next vCol
wsSal.Range("A" & r & ":AG" & r + 2).BorderAround Weight:=xlMedium
Application.DisplayAlerts = True
targetRow = targetRow + 3
End If
Next i
' Подвал
With wsSal
.Cells(targetRow, 31).Value = "ИТОГО:": .Cells(targetRow, 31).Font.Bold = True
.Cells(targetRow, 32).Formula = "=SUM(AF9:AF" & targetRow - 1 & ")"
With .Range(.Cells(targetRow, 31), .Cells(targetRow, 32))
.Borders.LineStyle = xlContinuous: .Borders.Weight = xlMedium: .Interior.Color = RGB(255, 255, 153)
End With
.Cells(targetRow + 2, 2).Value = "Ответственный: ________________ /" & managerName & "/"
.Cells(targetRow + 4, 2).Value = "Бухгалтер: ________________ /" & accountantName & "/"
.Range(.Cells(targetRow + 2, 2), .Cells(targetRow + 4, 2)).Font.Bold = True
.Columns("AF:AG").NumberFormat = "#,##0"
.Range("Q9:AE" & targetRow).NumberFormat = "#,##0.00"
.Columns("C").ColumnWidth = 28
End With
wsSal.Activate: Application.ScreenUpdating = True
MsgBox "Расчет завершен! Столбец AG добавлен.", vbInformation
End Sub
