Нужен скрипт "суммирование" на панели инструментов

[skia]

Всем привет. Нужна ваша помощь.
Есть скрипт со следующим кодом:

Option Explicit
Private sh As Worksheet 'лист на котором происходит подсчёт

'Основная процедура
Private Sub CommandButton1_Click()
Set sh = ActiveSheet 'лист на котором происходит подсчёт
Application.ScreenUpdating = False 'временно отрубаем обновление экрана
Call DeleteEmptyRows 'Удаляем все пустые записи
Call Sortirovka 'Сортируем по названию
Call Summiruem 'Находим одинаковые записи и суммируем их значения
Application.ScreenUpdating = True 'надо бы снова включить обновление экрана...
End Sub

'Удаляем все пустые записи
Private Sub DeleteEmptyRows()
'LastRow - последняя используемая строка, количество строк
'r - очередная строка
Dim LastRow As Long, r As Long
With sh.UsedRange
LastRow = .Rows.Count 'количество строк в используемом диапазоне
For r = LastRow To 3 Step -1 'от последней строки и до третьей
If .Cells(r, 1) = "" Then .Rows(r).Delete 'нет названия - удаляем всю строку!!!
Next
End With
End Sub

'Сортируем записи по названию
Private Sub Sortirovka()
Dim endRow As Long 'номер последней строки
With sh.UsedRange
.Cells(3, 1).End(xlDown).Select 'выделяем - от первой записи и до последней
endRow = ActiveCell.Row
'сортируем от первой записи и до последней по названиям
.Range(Cells(3, 1), Cells(endRow, 3)).Sort key1:=Columns(1)
End With
End Sub

'Находим одинаковые записи и суммируем их значения
'Напоминаю, что записи уже отсортированы по названиям
'У записей есть НАЗВАНИЯ (1-й столбец) и ЗНАЧЕНИЯ (2-й столбец)
Private Sub Summiruem()
Dim i As Long 'номер строки текущей записи
Dim sum As Double 'общая сумма
'строковые переменные для названий текущей записи и не-числа в значениях записей
Dim tek, tek2, brak As String
i = 3: sum = 0: brak = "" 'начинаем с 3-й строчки, пока всё по нулям
'Итак, поехали!
Do
With sh
tek = .Cells(i, 1) 'название очередной записи
tek2 = .Cells(i + 1, 1) 'название записи строкой ниже
If Not IsNumeric(.Cells(i, 2)) And .Cells(i, 2) <> "" Then
'Если значение записи не-число, то кидаем в "брак"
brak = brak & " [" & .Cells(i, 2) & "]"
Else
sum = sum + .Cells(i, 2) 'приплюсовали к общей сумме - если это было число
End If
If tek = tek2 Then 'если две подряд записи с одинаковыми названиями
'то первую удаляем - так как её значение к сумме уже приплюсовали
.Rows(i).Delete
Else 'ну а если названия разные...
.Cells(i, 2) = sum 'записываем для текущей записи всё что подсчитали
'если были нечисловые значения - сообщаем об этом в той же строке
If brak <> "" Then .Cells(i, 3) = "БРАК - " & brak
sum = 0 'обнуляем сумму
brak = "" 'очищаем корзинку для "брака"
i = i + 1 'переходим к записи строкой ниже с другим названием!
End If
End With
Loop Until tek = "" 'и так до тех пор пока не закончатся записи
End Sub

Но он привязан к определенному документу excel. Можно как-нибудь его унифицировать, чтобы он запускался с панели инструментов и его можно было применить к другим документам с одинаковым расположением строк и колонок?

[SAS888]

Во-первых, макросы написаны очень не рационально.
Во-вторых, если требуется, чтобы эта процедура всегда была доступна? Тогда нужно создать надстройку.

[skia]

Гут. Объясните плиз как это делать. На счет рациональности - согласен, но писал не я, да и мне главное, чтобы работал.

[EducatedFool]

Скопируйте файл из вложения куда-нибудь к себе на компьютер, и подключите его как надстройку (меню Сервис - Надстройки)

В главном меню увидите кнопку Обработать данные, которая и будет запускать Ваш макрос.

[skia]

Добавил, но он работает неправильно. Изначально он искал в первой колонке совпадение значений (имен) и суммировал их значения из второй. Если имя в первой колонке было уникальным, то он его просто переписывал с его значением.

[EducatedFool]

он работает неправильно

И что? Кто-то разве просил переделать скрипт?

Вы просили сделать этот скрипт независимым от файла:

Но он привязан к определенному документу excel. Можно как-нибудь его унифицировать, чтобы он запускался с панели инструментов и его можно было применить к другим документам с одинаковым расположением строк и колонок?

Я это и сделал. В код изменений не вносил.
К тому же SAS888 уже дал Вам понять, что макросы написаны не лучшим образом.

Если бы Вы написали, чего Вы хотели добиться этим кодом, и прикрепили бы пример обрабатываемого файла, - другое дело, можно было бы что-то подправить в коде.

[skia]

Тогда объясняю: есть ежемесячный отчет активности пользователей на форуме в формате excel (http://depositfiles.com/files/7z7vejfny). Такой отчет формируется каждый месяц. В отчете на одном листе несколько разделов=разделы форума. Пользователь может отвечать в разных разделах на разное количество вопросов. Это фиксируется в колонке Answer. Нужно, чтобы скрипт суммировал значения Answer для каждого пользователя во всех разделах.

[skia]

Сможете помочь?

[EducatedFool]

Возможно, вам достаточно будет такого макроса:

Sub test()
    Dim sh As Worksheet: Set sh = ActiveSheet
    Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
    Dim ra As Range: Set ra = Intersect(sh.UsedRange.SpecialCells(xlCellTypeConstants), sh.Columns(6))
    [i1].AutoFill [i1].Resize(, 2), xlFillFormats: [i1].Next = "Количество постов"
    Dim cell As Range
    For Each cell In ra.Cells
        If IsNumeric(cell.Value) And cell.MergeArea.Cells.Count = 1 Then
            res = "=СУММЕСЛИ(A3:A44;" & cell.Offset(, -5).Address & ";G3:G44)"
            cell.Offset(, 4).FormulaLocal = res
        End If
    Next cell
    sh.Columns(10).AutoFit: Application.Calculation = xlCalculationAutomatic
End Sub

Он создаст дополнительный столбец, в котором будут подсчитаны посты каждого участника форума.

[skia]

Что-то не получилось. Вот как этот макрос сработал