Суммирование из одинаковых ячеек

[Сергей И.]

Я немного изменил макрос, чтобы он работал на любом листе, а не только на первом

    iLastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

На втором листе все нормально разбивается.
А вот на третьем да, есть проблемка.
Посмотри на выделенные ячейки на втором и третьем листах.
На 3 листе перед словом "(диагональ)" есть пробел.
Макрос разбивает содержимое ячейки по разделителю " (" "пробел и скобка", и забирает следующее слово до пробела.
Для решения проблемы нужно изменить строку на 3 листе.
Или удалить пробел перед скобкой у слова "(диагональ)" или заменить его на другой знак(тире, подчеркивание)

[maksvas]

Огромное спасибо Сергею!!!
Я все понял, в следующий раз буду менять вместо пробела ставить знак "_" и будет проблема меньше. Еще раз вам спасибо!!!

Можно так писать в строке: 7201_Туфли_размер44 52 и будет легко разбить текст по столбцам из меню Данные. Чтобы оператору легко разбить текст по проще, потому что он почти не знает о макросе.

[моль]

Подскажите пл3 как решить схожую задачку.

Имеется таблица с формулой:

Фартук_размер46 1 2 5 10
Фартук_размер42 1 4 1 4
Шапка_вязальная 1 5 1 5
Фартук_размер46 1 2 5 10
Фартук_размер42 1 4 1 4
Итого: 33

(где второй столбец – количество однотипных изделий)

Требуется объединить и просуммировать ячейки с однотипными издельями, у которых все параметры совпадают.

Должно быть:

Фартук_размер46 2 2 5 20
Фартук_размер42 2 4 1 8
Шапка_вязальная 1 5 1 5
Итого: 33

В таком стиле нужно переработать сотни страниц Excel. Буду признателен за помощь.

[Hugo121]

Пример в файле очень желателен.
И непонятно, например такое может быть, или нет?
Фартук_размер46 1 2 5
Фартук_размер46 1 3 4
И можно ли как уникальное значение брать Фартук_размер46 2 5 - в таком случае Фартук_размер46 3 4 уже будет суммироваться отдельно.

Пока так:

Option Explicit


Sub Otbor()
    Dim a(), oDict As Object, i As Long, temp As String, kk
    
    With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    
    a = Range("A1:E" & Range("A" & Rows.Count).End(xlUp).Row).Value

    Set oDict = CreateObject("Scripting.Dictionary")
    oDict.CompareMode = vbTextCompare
    
    For i = 1 To UBound(a)
        temp = Application.Trim(a(i, 1) & "|" & a(i, 3) & "|" & a(i, 4))
        If Not oDict.Exists(temp) Then
            ReDim b(1 To 2)
            b(1) = a(i, 2): b(2) = a(i, 5)
            oDict.Add temp, b
        Else
            b = oDict.Item(temp)
            b(1) = b(1) + a(i, 2): b(2) = b(2) + a(i, 5)
            oDict.Item(temp) = b
        End If
    Next

    
    With Workbooks.Add
        i = 0
        For Each kk In oDict.keys
        i = i + 1
        .Worksheets(1).Range("A" & i) = Split(kk, "|")(0)
        .Worksheets(1).Range("B" & i) = oDict.Item(kk)(1)
        .Worksheets(1).Range("C" & i) = Split(kk, "|")(1)
        .Worksheets(1).Range("D" & i) = Split(kk, "|")(2)
        .Worksheets(1).Range("E" & i) = oDict.Item(kk)(2)
        Next
    End With
    

    .DisplayAlerts = True
    .ScreenUpdating = True
    End With
End Sub

[моль]

Вот пример.
Касательно фартука:
Фартук_размер46 имеет параметры всегда 2 и 5, как и все изделия имеют свои единственные неизменные параметры.

Hugo121, можешь оставить аську в личку, не знаю как пользоваться макросами.

[Hugo121]

Моль, аськи у меня нет - пишите в личку.
Вам написать не получилось.

[моль]

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

Заранее благодарен, моль.

[Hugo121]

Вот, под Ваш файл, но с рассчётом, что в файле в А1="№", B1="Модель" и т.д., т.е Вашу таблицу переместите в A1:

Option Explicit


Sub Otbor()
    Dim a(), oDict As Object, i As Long, temp As String, kk, rr As Range

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        Set rr = [a1:h2]

        a = Range("B3:H" & Range("A" & Rows.Count).End(xlUp).Row).Value

        Set oDict = CreateObject("Scripting.Dictionary")
        oDict.CompareMode = vbTextCompare

        For i = 1 To UBound(a)
            'в массиве a:
            '1=Модель
            '2=Наименование оборудования
            '3=Количество однотипного оборудования
            '4=Уст. мощность, кВт
            '5=Время работы, ч
            '6=Коэф. испол
            '7=Расход, кВт.ч

            temp = Application.Trim(a(i, 1) & "|" & a(i, 2) & "|" & a(i, 4) & "|" & a(i, 5) & "|" & a(i, 6))
            If Not oDict.Exists(temp) Then
                ReDim b(1 To 2)
                b(1) = a(i, 3): b(2) = a(i, 7)
                oDict.Add temp, b
            Else
                b = oDict.Item(temp)
                b(1) = b(1) + a(i, 3): b(2) = b(2) + a(i, 7)
                oDict.Item(temp) = b
            End If
        Next


        With Workbooks.Add.Sheets(1)
            rr.Copy .[a1]
            i = 2
            For Each kk In oDict.keys
                i = i + 1
                .Range("B" & i) = Split(kk, "|")(0)    'Модель
                .Range("C" & i) = Split(kk, "|")(1)    'Наименование оборудования
                .Range("D" & i) = oDict.Item(kk)(1)    'Количество
                .Range("E" & i) = CDbl(Split(kk, "|")(2))    'Уст. мощность
                .Range("F" & i) = CDbl(Split(kk, "|")(3))    'Время работы
                .Range("G" & i) = CDbl(Split(kk, "|")(4))    'Коэф. испол
                .Range("H" & i) = oDict.Item(kk)(2)    'Расход
            Next
            .Cells(i + 1, 8).Formula = "=sum(H3:H" & i & ")"
        End With


        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub

Да, в итоге нужно вручную поставить формат ячейкам с выгруженными значениями, ну или можно прописать в макрос, если это не разовая работа.

P.S. Добавил макрос в файл.
Ещё немного поправил формат вывода и добавил сумму.

[моль]

Благодарю, все работает.

[моль]

Hugo121, Вас не затруднит еще раз немного подправить макрос?
В прошлый раз за 15 минут удалось сократить документ со 200 до 150 страниц, однако теперь условия немножко изменились.