Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Поиск одинаковых ячеек, суммирование соседних ячеек,удаление - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Поиск одинаковых ячеек, суммирование соседних ячеек,удаление (Макросы/Sub)
Поиск одинаковых ячеек, суммирование соседних ячеек,удаление
Yar4i4 Дата: Вторник, 16.02.2016, 07:44 | Сообщение № 1
Группа: Пользователи
Ранг: Участник
Сообщений: 71
Репутация: 0 ±
Замечаний: 20% ±

Excel 2013
Доброе утро!
Нужен макрос
1п. поиска ячеек в столбце B, содержащих строго фиксированный одинаковый текст.
2п. С последующим суммированием значений в ячейках, находящихся справа через одну ячейку.
3п. С последующим удалением строк с одинаковыми ячейками в столбце B, но оставлением той строки в которой выведена сумма подсчитанная в пункте 2.

Я извиняюсь. если не просто всё написал, сейчас расскажу с привязкой к примеру:
1. Найти в столбце B абсолютно одинаковые ячейки содержащие заранее известный мне текст "Электроды", "Эмаль" или "Грунтовка". ("Эмаль" и "Грунт-эмаль..." - это разные ячейки, а также "Электроды" и "Электроды 4 мм" - это тоже разные ячейки, и не учитывать пустые ячейки - такие как B1, B2,.. B14,.. B37).
2. Просуммировать значения для "Электроды" в столбце D (D22+D23+D24) и итог вывести в любой из ячеек (D22,D23,D24), можно во всех вывести.
3. Удалить строки содержащие одинаковые ячейки, но оставить одну (любую) ячейку, отражающую сумму в столбце D.

В прикреплённом файле я использовал цвет - это только для наглядности. Также там имеется второй лист - он содержит вид конечного (желаемого) результата.
На единицы измерения не обращайте внимания.
Спасибо.
К сообщению приложен файл: 9999999999.xlsx (14.5 Kb)
 
Ответить
СообщениеДоброе утро!
Нужен макрос
1п. поиска ячеек в столбце B, содержащих строго фиксированный одинаковый текст.
2п. С последующим суммированием значений в ячейках, находящихся справа через одну ячейку.
3п. С последующим удалением строк с одинаковыми ячейками в столбце B, но оставлением той строки в которой выведена сумма подсчитанная в пункте 2.

Я извиняюсь. если не просто всё написал, сейчас расскажу с привязкой к примеру:
1. Найти в столбце B абсолютно одинаковые ячейки содержащие заранее известный мне текст "Электроды", "Эмаль" или "Грунтовка". ("Эмаль" и "Грунт-эмаль..." - это разные ячейки, а также "Электроды" и "Электроды 4 мм" - это тоже разные ячейки, и не учитывать пустые ячейки - такие как B1, B2,.. B14,.. B37).
2. Просуммировать значения для "Электроды" в столбце D (D22+D23+D24) и итог вывести в любой из ячеек (D22,D23,D24), можно во всех вывести.
3. Удалить строки содержащие одинаковые ячейки, но оставить одну (любую) ячейку, отражающую сумму в столбце D.

В прикреплённом файле я использовал цвет - это только для наглядности. Также там имеется второй лист - он содержит вид конечного (желаемого) результата.
На единицы измерения не обращайте внимания.
Спасибо.

Автор - Yar4i4
Дата добавления - 16.02.2016 в 07:44
Апострофф Дата: Вторник, 16.02.2016, 08:12 | Сообщение № 2
Группа: Проверенные
Ранг: Обитатель
Сообщений: 444
Репутация: 122 ±
Замечаний: 0% ±

Excel 1997
Пробуйте (половина сделана в макрорекордере) -

[vba]
Код
Sub Макрос2()
    Range("B20").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Sort Key1:=Range("B20"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
Dim r&, rn As Range
Set rn = Selection
For r = rn.Rows.Count To 2 Step -1
  If rn(r, 1) = rn(r - 1, 1) Then rn(r - 1, 3) = rn(r - 1, 3) + rn(r, 3): rn(r, 1).EntireRow.Delete
Next
End Sub
[/vba]
 
Ответить
СообщениеПробуйте (половина сделана в макрорекордере) -

[vba]
Код
Sub Макрос2()
    Range("B20").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Sort Key1:=Range("B20"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
Dim r&, rn As Range
Set rn = Selection
For r = rn.Rows.Count To 2 Step -1
  If rn(r, 1) = rn(r - 1, 1) Then rn(r - 1, 3) = rn(r - 1, 3) + rn(r, 3): rn(r, 1).EntireRow.Delete
Next
End Sub
[/vba]

Автор - Апострофф
Дата добавления - 16.02.2016 в 08:12
nilem Дата: Вторник, 16.02.2016, 08:15 | Сообщение № 3
Группа: Авторы
Ранг: Старожил
Сообщений: 1612
Репутация: 563 ±
Замечаний: 0% ±

Excel 2013, 2016
или вот без рекордера :)
[vba]
Код
Sub ertert()
Dim x, y(), i&, j&, k&, n&
x = Range("A20:H" & Cells(Rows.Count, 2).End(xlUp).Row + 1).Value
ReDim y(1 To UBound(x), 1 To UBound(x, 2))
On Error Resume Next
With New Collection
    For i = 1 To UBound(x)
        If IsEmpty(.Item(x(i, 2))) Then
            k = k + 1
            For j = 1 To UBound(x, 2)
                y(k, j) = x(i, j)
            Next j
            .Add Item:=k, Key:=x(i, 2)
        Else
            n = .Item(x(i, 2))
            y(n, 4) = y(n, 4) + x(i, 4)
        End If
    Next i
End With

With Range("A20:H" & Cells(Rows.Count, 2).End(xlUp).Row + 1)
    .ClearContents: .Resize(k).Value = y()
End With
End Sub
[/vba]


Яндекс.Деньги 4100159601573
 
Ответить
Сообщениеили вот без рекордера :)
[vba]
Код
Sub ertert()
Dim x, y(), i&, j&, k&, n&
x = Range("A20:H" & Cells(Rows.Count, 2).End(xlUp).Row + 1).Value
ReDim y(1 To UBound(x), 1 To UBound(x, 2))
On Error Resume Next
With New Collection
    For i = 1 To UBound(x)
        If IsEmpty(.Item(x(i, 2))) Then
            k = k + 1
            For j = 1 To UBound(x, 2)
                y(k, j) = x(i, j)
            Next j
            .Add Item:=k, Key:=x(i, 2)
        Else
            n = .Item(x(i, 2))
            y(n, 4) = y(n, 4) + x(i, 4)
        End If
    Next i
End With

With Range("A20:H" & Cells(Rows.Count, 2).End(xlUp).Row + 1)
    .ClearContents: .Resize(k).Value = y()
End With
End Sub
[/vba]

Автор - nilem
Дата добавления - 16.02.2016 в 08:15
Yar4i4 Дата: Вторник, 16.02.2016, 08:53 | Сообщение № 4
Группа: Пользователи
Ранг: Участник
Сообщений: 71
Репутация: 0 ±
Замечаний: 20% ±

Excel 2013
Цитата Апострофф, 16.02.2016 в 08:12, в сообщении № 2
Пробуйте

Спасибо. Работает.
И по алфавитному порядку расставляет. Я думал об этом - для удобства визуального поиска полезность №1. Спасибо.


Спасибо. Работает.

И что характерно, нет необходимости проставлять известные слова для поисковика - всё автоматически суммирует.
Спасибо чудесно всё.
 
Ответить
Сообщение
Цитата Апострофф, 16.02.2016 в 08:12, в сообщении № 2
Пробуйте

Спасибо. Работает.
И по алфавитному порядку расставляет. Я думал об этом - для удобства визуального поиска полезность №1. Спасибо.


Спасибо. Работает.

И что характерно, нет необходимости проставлять известные слова для поисковика - всё автоматически суммирует.
Спасибо чудесно всё.

Автор - Yar4i4
Дата добавления - 16.02.2016 в 08:53
nilem Дата: Четверг, 10.03.2016, 09:39 | Сообщение № 5
Группа: Авторы
Ранг: Старожил
Сообщений: 1612
Репутация: 563 ±
Замечаний: 0% ±

Excel 2013, 2016
ответ на ЛС
вот с учетом ед. изм.


Яндекс.Деньги 4100159601573
 
Ответить
Сообщениеответ на ЛС
вот с учетом ед. изм.

Автор - nilem
Дата добавления - 10.03.2016 в 09:39
Yar4i4 Дата: Четверг, 10.03.2016, 15:51 | Сообщение № 6
Группа: Пользователи
Ранг: Участник
Сообщений: 71
Репутация: 0 ±
Замечаний: 20% ±

Excel 2013

спасибо работает


Сообщение отредактировал Yar4i4 - Пятница, 11.03.2016, 06:26
 
Ответить
Сообщение
спасибо работает

Автор - Yar4i4
Дата добавления - 10.03.2016 в 15:51
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Поиск одинаковых ячеек, суммирование соседних ячеек,удаление (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!