Sub Bijsumm()
Main "Начало бижутерии", "Конец бижутерии"
End Sub
Private Sub Main(strStartPhrase As String, strEndPhrase As String)
Dim sh_act As Worksheet, tbl As Range
Dim dicDopi As Object
Dim arrB()
Dim arrBlankRows() As Long
Dim lngRowIndex As Long
Dim hr As Long, lr As Long, i As Long
Dim KodVd As Variant, a As Variant
Dim k As Integer
Dim Nachalo As Integer, lngKonec As Integer
Nachalo = НачалоДанных
lngKonec = КонецДанных
'1. Создание ссылки на активный лист.
Set sh_act = ActiveSheet
If sh_act Is Nothing Then
Exit Sub
End If
ActiveSheet.name = "Апсны"
With ActiveWorkbook.Sheets("Апсны").Tab
.Color = 10092390
.TintAndShade = 0
End With
'2. Поиск шапки и последней строки таблицы.
S_Hr.Function2 sh_act, hr, lr
'3. Копирование данных по допам из листа-надстройки в словарь "dicDopi".
If BIJ_BIJ_SUM_2_GetAddin.Function1(dicDopi) = False Then
Exit Sub
End If
'4. Создание ссылки на таблицу.
' Включение в таблицу строки после таблицы.
Set tbl = sh_act.Rows(hr & ":" & lr + 1)
'5.
' Копирование столбца B в массив "arrB".
' Подготовка данных к сравнению.
arrB() = tbl.Columns("B").Value
For i = 1 To UBound(arrB, 1) Step 1
arrB(i, 1) = CStr(arrB(i, 1))
Next i
'6. Получение информации о пустых строках в массив "arrBlankRows".
ReDim arrBlankRows(1 To 1)
' Первая строка - шапка.
' Во вторую строку не вставляется формула, но первая строка нужна
' для расчёта формулы в нижерасположенной пустой строке.
For i = 2 To UBound(arrB, 1) Step 1
' Учитываются все пустые строки, т.к. надо будет потом вставлять формулы
' с учётом вышестоящих пустых строк.
If arrB(i, 1) = "" Then
arrBlankRows(UBound(arrBlankRows)) = i
ReDim Preserve arrBlankRows(1 To UBound(arrBlankRows) + 1)
End If
Next i
' Если не было пустых ячеек в столбце B или была пустая ячейка только во второй строке,
' то дальше нет смысла что-то делать.
If UBound(arrBlankRows) < 3 Then
MsgBox "В таблице, в столбце ""B"" нет пустых ячеек. " & _
"Макрос вставляет суммы в пустые ячейки.", vbExclamation
Exit Sub
End If
' Удаление последнего элемента из массива "arrBlankRows", который создавался заранее.
ReDim Preserve arrBlankRows(1 To UBound(arrBlankRows) - 1)
'7. Откл. монитора.
' Application.ScreenUpdating = False
'8. Вставка формул.
' В массиве "arrBlankRows" могут находиться три вида пустых строк:
'1) пустые строки с заголовками групп;
'2) пустые строки, в которые не надо вставлять формулы;
'3) пустые строки, в которые надо вставлять формулы.
' Первая пустая строка - это сразу после шапки таблицы. В неё не надо вставлять формулы.
For i = 2 To UBound(arrBlankRows) Step 1
' Помещение порядкового номера Excel-строки в переменную для удобства.
lngRowIndex = arrBlankRows(i)
' Пустые строки с заголовками групп пропускаем.
' Они определяются по двум подряд стоящим пустым строкам.
If arrB(lngRowIndex - 1, 1) = "" Then
' Переход к следующей пустой строке.
GoTo metka
End If
' Если над пустой строкой через одну строку пусто, значит
' блок состоит из одной строки и формулы не надо вставлять.
' Сверху пустая строка может быть двух видов:
' 1) пустая строка с заголовком группы;
' 2) пустая строка между блоками.
' В любом случае действие будет одинаковое.
If arrB(lngRowIndex - 2, 1) = "" Then
' В столбец "S" нужно вставлять данные на основе словаря "dicDopi".
If dicDopi.Exists(key:=CStr(tbl.Cells(lngRowIndex - 1, "D"))) = True Then
If dicDopi.Item(key:=CStr(tbl.Cells(lngRowIndex - 1, "D"))) = "ДОП НУЖЕН" Then
' With tbl.Cells(lngRowIndex - 1, "S")
' .Value = tbl.Cells(lngRowIndex - 1, "K").Value
' ' Форматирование.
' .Interior.Color = 65535
' '.BorderAround xlContinuous!!!нахуй нужны бордюры!!!
'
' End With
End If
End If
' Если сверху над пустой строкой несколько непустых строк, то
' вставка формул (формулы проще вставить, чем рассчитывать с помощью макроса).
Else
tbl.Cells(lngRowIndex, "K").FormulaR1C1 = _
"=ROUND(SUM(R[-" & lngRowIndex - arrBlankRows(i - 1) - 1 & "]C:R[-1]C),2)"
tbl.Cells(lngRowIndex, "N").Resize(1, 2).FormulaR1C1 = _
"=ROUND(SUM(R[-" & lngRowIndex - arrBlankRows(i - 1) - 1 & "]C:R[-1]C),2)"
tbl.Cells(lngRowIndex, "R").FormulaR1C1 = _
"=ROUND(SUM(R[-" & lngRowIndex - arrBlankRows(i - 1) - 1 & "]C:R[-1]C),2)"
' Выделение цветом.
tbl.Cells(lngRowIndex, "K").Resize(1, 8).Interior.Color = 65535
' ' В столбец "S" нужно вставлять данные на основе словаря "dicDopi".
If dicDopi.Exists(key:=CStr(tbl.Cells(lngRowIndex - 1, "D"))) = True Then
If dicDopi.Item(key:=CStr(tbl.Cells(lngRowIndex - 1, "D"))) = "ДОП НУЖЕН" Then
a = CStr(tbl.Cells(lngRowIndex - 1, "D").Value) '
'переводим текстовый в числовой:
' это числовой в текстовый:
'KodVd = "" & KodVd
a = Val(a)
' допы простовляем напротив каждой. ибо нех.
For k = Nachalo To lngKonec Step 1
KodVd = Val(ActiveSheet.Cells(k, 4).Value)
If KodVd = a Then
Cells(k, 19) = Cells(k, 11)
With Cells(k, "S")
.HorizontalAlignment = xlCenter
.BorderAround xlContinuous '!!!нахуй нужны бордюры!!!
End With
End If
Next
' вот здесь в столбце S будет суммировать промежуточные итоги:
tbl.Cells(lngRowIndex, "S").FormulaR1C1 = _
"=ROUND(SUM(R[-" & lngRowIndex - arrBlankRows(i - 1) - 1 & "]C:R[-1]C),2)"
With tbl.Cells(lngRowIndex, "S")
' .Value = tbl.Cells(lngRowIndex, "K").Value ' это значение из столбца K одставляеться, а мне нужно , чтоли суммироувало
.Interior.Color = 65535
.HorizontalAlignment = xlCenter
.Font.Bold = True
.BorderAround xlContinuous '!!!нахуй нужны бордюры!!!
End With
'
' это значение из столбца K подставляться:
'
' это ориганальный код:
' ' В столбец "S" нужно вставлять данные на основе словаря "dicDopi".
' If dicDopi.Exists(key:=CStr(tbl.Cells(lngRowIndex - 1, "D"))) = True Then
' If dicDopi.Item(key:=CStr(tbl.Cells(lngRowIndex - 1, "D"))) = "ДОП НУЖЕН" Then
' With tbl.Cells(lngRowIndex, "S")
' .Value = tbl.Cells(lngRowIndex, "K").Value ' это значение из столбца K одставляеться, а мне нужно , чтоли суммироувало
' .Interior.Color = 65535
' .BorderAround xlContinuous '!!!нахуй нужны бордюры!!!
' End With
End If
End If
End If
metka:
Next i
'9. Создание справа таблицы с кол-вом мест.
'S_KOLMEST_1_CreateTbl.Main sh_act
'10. Включение обновления монитора.
'Application.ScreenUpdating = True
End Sub
|