lyns.pro :: Важно? Не важно! Раньше для рабочих задач мне приходилось вручную добавлять к таблице со списком книг отдельную таблицу для заказов по филиалам — с формулами для подсчёта количества и суммы. Со временем это стало слишком утомительно, поэтому я решил автоматизировать процесс: теперь таблица строится сама, учитывая все филиалы из массива.
Option Explicit
Sub BuildBranchColumnsSafe()
Dim ws As Worksheet
Set ws = ActiveSheet
' === Настройки ===
Dim branches As Variant
branches = Array("256", "258", "259", "260", "261", "262", "263", "264", "265", "Юбилейный") ' <-- Массив с филиалами
Const BASE_COL As Long = 8 ' H — Колонка для формулы "Сумма"
Const SPACER_COL As Long = 9 ' I — Это колонка отступ
Const START_COL As Long = 10 ' J — С этой колонки будем рисовать
Const SPACER_COL_WIDTH = 1 ' Ширина колонки "отступа"
Const HEADER_ROW_1 As Long = 1
Const HEADER_ROW_2 As Long = 2
Const FIRST_DATA_ROW As Long = 3
Dim lastDataRow As Long
lastDataRow = SafeLastRow(ws, BASE_COL, FIRST_DATA_ROW)
If lastDataRow < FIRST_DATA_ROW Then lastDataRow = FIRST_DATA_ROW
' === ОТКЛЮЧАЕМ ТЯЖЕЛЫЕ ВЕЩИ НА ВРЕМЯ ПОСТРОЕНИЯ ===
Dim oldCalc As XlCalculation, oldScrUp As Boolean, oldEvt As Boolean
oldCalc = Application.Calculation
oldScrUp = Application.ScreenUpdating
oldEvt = Application.EnableEvents
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
On Error GoTo CleanFail
' (Необязательно) Очистка колонки-отступа от содержимого
ws.Columns(SPACER_COL).ClearContents
ws.Columns(SPACER_COL).ColumnWidth = SPACER_COL_WIDTH
' Перед построением снимаем старые объединения ячеек в нашей зоне построения
Call UnmergeHead(ws, START_COL, START_COL + UBound(branches) * 2 + 1, HEADER_ROW_1, HEADER_ROW_2)
Dim i As Long, qtyCol As Long, sumCol As Long
For i = LBound(branches) To UBound(branches)
qtyCol = START_COL + i * 2
sumCol = qtyCol + 1
' Шапка: объединение на строке 1
With ws.Range(ws.Cells(HEADER_ROW_1, qtyCol), ws.Cells(HEADER_ROW_1, sumCol))
If .MergeCells Then .UnMerge
.Merge
.Value = branches(i)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Font.Bold = True
.Borders.LineStyle = xlContinuous
End With
' === Формат шапки с названием филиала ===
With ws.Range(ws.Cells(HEADER_ROW_1, qtyCol), ws.Cells(HEADER_ROW_1, sumCol))
.Font.Name = "Times New Roman"
.Font.Size = 10
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Interior.Color = 13431551
End With
' Строка 2: подзаголовки
ws.Cells(HEADER_ROW_2, qtyCol).Value = "кол-во"
ws.Cells(HEADER_ROW_2, sumCol).Value = "сумма"
With ws.Range(ws.Cells(HEADER_ROW_2, qtyCol), ws.Cells(HEADER_ROW_2, sumCol))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Bold = True
.Borders.LineStyle = xlContinuous
End With
' === Формат подзаголовков и ширина колонок ===
With ws.Range(ws.Cells(HEADER_ROW_2, qtyCol), ws.Cells(HEADER_ROW_2, sumCol))
.Font.Name = "Times New Roman"
.Font.Size = 8
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
ws.Columns(qtyCol).ColumnWidth = 5
ws.Columns(sumCol).ColumnWidth = 7.5
' Диапазон строк с данными
Dim dataRngQty As Range, dataRngSum As Range
Set dataRngQty = ws.Range(ws.Cells(FIRST_DATA_ROW, qtyCol), ws.Cells(lastDataRow, qtyCol))
Set dataRngSum = ws.Range(ws.Cells(FIRST_DATA_ROW, sumCol), ws.Cells(lastDataRow, sumCol))
' === Формат данных ===
If Not dataRngQty Is Nothing Then
With dataRngQty
.Font.Name = "Times New Roman"
.Font.Size = 12
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End If
If Not dataRngSum Is Nothing Then
With dataRngSum
.Font.Name = "Times New Roman"
.Font.Size = 8
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
End With
End If
' Валидация 0..5 для "кол-во"
On Error Resume Next
dataRngQty.Validation.Delete
On Error GoTo 0
If dataRngQty.Rows.Count > 0 Then
dataRngQty.Validation.Add Type:=xlValidateWholeNumber, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="0", Formula2:="5"
With dataRngQty.Validation
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = "Введите от 0 до 5"
.InputMessage = "Только целые числа 0…5."
.ErrorTitle = "Недопустимое значение"
.ErrorMessage = "Введите цело число от 0 до 5."
End With
End If
' Формула для "сумма" (значение из колонки H * кол-во)
If dataRngSum.Rows.Count > 0 Then
dataRngSum.FormulaR1C1 = "=RC8*RC[-1]"
dataRngSum.NumberFormat = "#,##0.00" & ChrW(32) & ChrW(&H20BD) ' Устанавливаем формат с валютой рубль
End If
' Итоговая сумма для кол-во
ws.Cells(lastDataRow + 1, qtyCol).Formula = "=SUM(" & ws.Range(ws.Cells(FIRST_DATA_ROW, qtyCol), ws.Cells(lastDataRow, qtyCol)).Address(False, False) & ")"
' Итоговая сумма для сумма
ws.Cells(lastDataRow + 1, sumCol).Formula = "=SUM(" & ws.Range(ws.Cells(FIRST_DATA_ROW, sumCol), ws.Cells(lastDataRow, sumCol)).Address(False, False) & ")"
ws.Cells(lastDataRow + 1, sumCol).NumberFormat = "#,##0.00" & ChrW(32) & ChrW(&H20BD) ' Устанавливаем формат с валютой рубль
' === Границы для таблицы ===
Dim headBlock As Range, totalBlock As Range, dataBlock As Range
Set dataBlock = ws.Range(ws.Cells(FIRST_DATA_ROW, qtyCol), ws.Cells(lastDataRow + 1, sumCol))
Set headBlock = ws.Range(ws.Cells(HEADER_ROW_1, qtyCol), ws.Cells(HEADER_ROW_2, sumCol))
Set totalBlock = ws.Range(ws.Cells(lastDataRow + 1, qtyCol), ws.Cells(lastDataRow + 1, sumCol))
' Тонкие границы для всех данных + итоговой строки
With dataBlock.Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
' Толстая рамка вокруг шапки
With headBlock.Borders(xlInsideVertical)
.LineStyle = xlContinuous: .Weight = xlThin
End With
With headBlock.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous: .Weight = xlThin
End With
With headBlock.Borders(xlEdgeLeft)
.LineStyle = xlContinuous: .Weight = xlMedium
End With
With headBlock.Borders(xlEdgeTop)
.LineStyle = xlContinuous: .Weight = xlMedium
End With
With headBlock.Borders(xlEdgeRight)
.LineStyle = xlContinuous: .Weight = xlMedium
End With
With headBlock.Borders(xlEdgeBottom)
.LineStyle = xlContinuous: .Weight = xlMedium
End With
' Толстая рамка для итоговой строки
With totalBlock.Borders(xlEdgeLeft)
.LineStyle = xlContinuous: .Weight = xlMedium
End With
With totalBlock.Borders(xlEdgeTop)
.LineStyle = xlContinuous: .Weight = xlMedium
End With
With totalBlock.Borders(xlEdgeRight)
.LineStyle = xlContinuous: .Weight = xlMedium
End With
With totalBlock.Borders(xlEdgeBottom)
.LineStyle = xlContinuous: .Weight = xlMedium
End With
Next i
' Суммируем все колонки "кол-во" по строке и записываем сумму в колонку 1
Dim sumFormula As String
Dim firstQtyCol As Long, lastQtyCol As Long
firstQtyCol = START_COL
lastQtyCol = START_COL + (UBound(branches)) * 2 ' т.к. "кол-во" — это первая колонка каждого блока
Dim qtyCols As String, c As Long
qtyCols = ""
For c = firstQtyCol To lastQtyCol Step 2
qtyCols = qtyCols & ws.Cells(FIRST_DATA_ROW, c).Address(False, False) & ","
Next c
qtyCols = Left(qtyCols, Len(qtyCols) - 1) ' убираем последнюю запятую
' Записываем формулу для всех строк с данными
With ws.Range(ws.Cells(FIRST_DATA_ROW, 1), ws.Cells(lastDataRow, 1))
.Formula = "=SUM(" & qtyCols & ")"
End With
' Итоги в колонках A (общее кол-во) и B (общая сумма)
Dim grandRow As Long
Dim qtyStartCol As Long, qtyEndCol As Long
Dim colIndex As Long
Dim qtyTotalsList As String, sumTotalsList As String
grandRow = lastDataRow + 1
qtyStartCol = START_COL
qtyEndCol = START_COL + (UBound(branches) * 2) ' последняя колонка "кол-во"
' Собираем адреса итогов под колонками "кол-во"
qtyTotalsList = ""
For colIndex = qtyStartCol To qtyEndCol Step 2
qtyTotalsList = qtyTotalsList & ws.Cells(grandRow, colIndex).Address(False, False) & ","
Next colIndex
If Len(qtyTotalsList) > 0 Then qtyTotalsList = Left(qtyTotalsList, Len(qtyTotalsList) - 1)
' Собираем адреса итогов под колонками "сумма"
sumTotalsList = ""
For colIndex = qtyStartCol + 1 To qtyEndCol + 1 Step 2
sumTotalsList = sumTotalsList & ws.Cells(grandRow, colIndex).Address(False, False) & ","
Next colIndex
If Len(sumTotalsList) > 0 Then sumTotalsList = Left(sumTotalsList, Len(sumTotalsList) - 1)
' Записываем формулы в A(grandRow) и B(grandRow)
If qtyTotalsList <> "" Then ws.Cells(grandRow, 1).Formula = "=SUM(" & qtyTotalsList & ")"
If sumTotalsList <> "" Then
ws.Cells(grandRow, 2).Formula = "=SUM(" & sumTotalsList & ")"
ws.Cells(grandRow, 2).NumberFormat = "#,##0.00" & ChrW(32) & ChrW(&H20BD) ' денежный формат для общего итога
End If
' === Форматирование итоговых ячеек A(grandRow) и B(grandRow) ===
Dim cellA As Range, cellB As Range, grandTotalBlock As Range
Set cellA = ws.Cells(grandRow, 1)
Set cellB = ws.Cells(grandRow, 2)
Set grandTotalBlock = ws.Range(cellA, cellB)
' A: общее кол-во — TNR 7, центр
With cellA
.Font.Name = "Times New Roman"
.Font.Size = 7
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
' B: общая сумма — TNR 11, по правому краю, по центру по вертикали + денежный формат (на всякий случай)
With cellB
.Font.Name = "Times New Roman"
.Font.Size = 11
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
If .NumberFormat = "General" Or .NumberFormat = "" Then
.NumberFormat = "#,##0.00" & ChrW(32) & ChrW(&H20BD)
End If
End With
' Границы: тонкая внутренняя между A и B, толстая общая рамка по краям блока
With grandTotalBlock.Borders
.LineStyle = xlContinuous
.Weight = xlThin ' базово — тонкие везде
End With
With grandTotalBlock.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin ' внутренняя между ячейками — обычная (тонкая)
End With
With grandTotalBlock.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium ' общая рамка — пожирнее
End With
With grandTotalBlock.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With grandTotalBlock.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
With grandTotalBlock.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
End With
CleanOk:
Application.Calculation = oldCalc
Application.ScreenUpdating = oldScrUp
Application.EnableEvents = oldEvt
'MsgBox "Готово.", vbInformation
Exit Sub
CleanFail:
' В случае ошибки — вернуть настройки и показать номер строки/описание
Application.Calculation = oldCalc
Application.ScreenUpdating = oldScrUp
Application.EnableEvents = oldEvt
MsgBox "Ошибка: " & Err.Number & " — " & Err.Description, vbExclamation
End Sub
' Возвращает безопасную «последнюю строку» по колонке baseCol:
' - ищет последнюю непустую ячейку снизу;
' - ограничивает диапазон, чтоб не получить миллион строк по случайному вводу;
' - если данных нет — возвращает FIRST_DATA_ROW.
Private Function SafeLastRow(ws As Worksheet, baseCol As Long, FIRST_DATA_ROW As Long) As Long
Dim r As Long
r = ws.Cells(ws.Rows.Count, baseCol).End(xlUp).Row
If r < FIRST_DATA_ROW Then
SafeLastRow = FIRST_DATA_ROW
Else
' Доп. страховка: если «случайно» очень далеко — ограничим, например, 10 000 строками
' (при желании увеличте лимит)
Dim MAX_ROWS As Long: MAX_ROWS = 10000
If r - FIRST_DATA_ROW + 1 > MAX_ROWS Then
SafeLastRow = FIRST_DATA_ROW + MAX_ROWS - 1
Else
SafeLastRow = r
End If
End If
End Function
' Снять объединение в шапке (если есть) в заданном диапазоне колонок.
Private Sub UnmergeHead(ws As Worksheet, firstCol As Long, lastCol As Long, hr1 As Long, hr2 As Long)
Dim rng As Range
Set rng = ws.Range(ws.Cells(hr1, firstCol), ws.Cells(hr1, lastCol))
If rng.MergeCells Then rng.UnMerge
' На всякий случай - подчистим и строку 2 там же
Set rng = ws.Range(ws.Cells(hr2, firstCol), ws.Cells(hr2, lastCol))
If rng.MergeCells Then rng.UnMerge
End Sub
Файл шаблон (Excel):