МАКРОС НА ПОИСК, СУММИРОВАНИЕ И УДАЛЕНИЕ ПОВТОРЯЮЩИХСЯ СТРОК

[provodnikam]

Здрасте!!!
Ребят, есть ОЧЕНЬ большая таблица в Эксель....поэтому сводные таблицы её не берут
Помогите создать макрос суть которого в следующем:
Если встречается строка с одинаковым наименованиес материала, то её ПОЛНОСТЬЮ нужно приплюсовать к имеющейся строке выше и удалить.
Пример во вложении

[provodnikam]

PHP код:

Rem Attribute VBA_ModuleType=VBADocumentModule
Sub Лист1
Rem Option Explicit
Rem Private sh As Worksheet 'лист на котором происходит подсчёт
Rem 
Rem 'Основная процедура
Rem Private Sub CommandButton1_Click()
Rem    Set sh = ActiveSheet 'лист на котором происходит подсчёт
Rem    Application.ScreenUpdating = False 'временно отрубаем обновление экрана
Rem    Call DeleteEmptyRows 'Удаляем все пустые записи
Rem    Call Sortirovka 'Сортируем по названию
Rem    Call Summiruem 'Находим одинаковые записи и суммируем их значения
Rem    Application.ScreenUpdating = True 'надо бы снова включить обновление экрана...
Rem End Sub
Rem 
Rem 'Удаляем все пустые записи
Rem Private Sub DeleteEmptyRows()
Rem    'LastRow - последняя используемая строка, количество строк
Rem    'r - очередная строка
Rem    Dim LastRow As Long, r As Long
Rem    With sh.UsedRange
Rem       LastRow = .Rows.Count 'количество строк в используемом диапазоне
Rem       For r = LastRow To 3 Step -1 'от последней строки и до третьей
Rem          If .Cells(r, 1) = "" Then .Rows(r).Delete 'нет названия - удаляем всю строку!!!
Rem       Next
Rem    End With
Rem End Sub
Rem 
Rem 'Сортируем записи по названию
Rem Private Sub Sortirovka()
Rem    Dim endRow As Long 'номер последней строки
Rem    With sh.UsedRange
Rem       .Cells(3, 1).End(xlDown).Select 'выделяем - от первой записи и до последней
Rem       endRow = ActiveCell.Row
Rem       'сортируем от первой записи и до последней по названиям
Rem       .Range(Cells(3, 1), Cells(endRow, 3)).Sort key1:=Columns(1)
Rem    End With
Rem End Sub
Rem 
Rem 'Находим одинаковые записи и суммируем их значения
Rem 'Напоминаю, что записи уже отсортированы по названиям
Rem 'У записей есть НАЗВАНИЯ (1-й столбец) и ЗНАЧЕНИЯ (2-й столбец)
Rem Private Sub Summiruem()
Rem    Dim i As Long 'номер строки текущей записи
Rem    Dim sum As Double 'общая сумма
Rem    'строковые переменные для названий текущей записи и не-числа в значениях записей
Rem    Dim tek, tek2, brak As String
Rem    i = 3: sum = 0: brak = "" 'начинаем с 3-й строчки, пока всё по нулям
Rem    'Итак, поехали!
Rem    Do
Rem       With sh
Rem          tek = .Cells(i, 1) 'название очередной записи
Rem          tek2 = .Cells(i + 1, 1) 'название записи строкой ниже
Rem          If Not IsNumeric(.Cells(i, 2)) And .Cells(i, 2) <> "" Then
Rem             'Если значение записи не-число, то кидаем в "брак"
Rem             brak = brak & " [" & .Cells(i, 2) & "]"
Rem          Else
Rem             sum = sum + .Cells(i, 2) 'приплюсовали к общей сумме - если это было число
Rem          End If
Rem          If tek = tek2 Then 'если две подряд записи с одинаковыми названиями
Rem          'то первую удаляем - так как её значение к сумме уже приплюсовали
Rem             .Rows(i).Delete
Rem          Else 'ну а если названия разные...
Rem             .Cells(i, 2) = sum 'записываем для текущей записи всё что подсчитали
Rem             'если были нечисловые значения - сообщаем об этом в той же строке
Rem             If brak <> "" Then .Cells(i, 3) = "БРАК - " & brak
Rem             sum = 0 'обнуляем сумму
Rem             brak = "" 'очищаем корзинку для "брака"
Rem             i = i + 1 'переходим к записи строкой ниже с другим названием!
Rem          End If
Rem       End With
Rem    Loop Until tek = "" 'и так до тех пор пока не закончатся записи
Rem End Sub
Rem 
Rem 
Rem 
End Sub 


[provodnikam]

предложили вышеуказанный коддд....однако, он только ссцмирует первую и вторую колонку, а надо всё....
плиз, помогите написать макрос...лучше в примере на xls

[The_Prist]

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

[provodnikam]

Спасибо - попробую попозже....обязательно напишу!!!!!!!!!!!!

[provodnikam]

СПАСИБО!!!!!!
Всё работает!!!!:-)

[zhdanov_as]

Помогите пожалуйста в такой ситуации, нужен макрос: есть таблица, формируется она довольно таки часто "во вложенных файлах", там есть одинаковый вид продукции, к примеру "сталь арматурная А3 ф10 (6) А500С ГОСТ5781-82" и "сталь арматурная А3 ф10 (11.7) А500С СТО АСЧМ 7-93", в скобках обозначается длина, также указывается коэффициент к каждой позиции, нужно чтобы оставалось лишь по одной позиции с наибольшим коэффициентом, отбор должен идти к примеру так "сталь арматурная А3 ф10" не учитывая длины и всех остальных обозначений. А то приходится самому сидеть и удалять балки, арматуру, шестигранники, очень долго по времени занимает. Заранее большое вам спасибо!

[doober]

Посмотрите здесь,Вам должно помочь в работе

[zhdanov_as]

Огромное спасибо, все отлично работает! Теперь экономлю на работе кучу времени.

[vashkostya]

Доброго времени суток.
Помогите создать макрос, чтобы предприятия в списке не повторялись. А суммы впредприятий которые повторяюстя в столбцах суммировались. Очень нужно! Заранее спасибо!

http://www.programmersforum.ru/attac...1&d=1290943122