Доброе утро! Нужен макрос 1п. поиска ячеек в столбце B, содержащих строго фиксированный одинаковый текст. 2п. С последующим суммированием значений в ячейках, находящихся справа через одну ячейку. 3п. С последующим удалением строк с одинаковыми ячейками в столбце B, но оставлением той строки в которой выведена сумма подсчитанная в пункте 2.
Я извиняюсь. если не просто всё написал, сейчас расскажу с привязкой к примеру: 1. Найти в столбце B абсолютно одинаковые ячейки содержащие заранее известный мне текст "Электроды", "Эмаль" или "Грунтовка". ("Эмаль" и "Грунт-эмаль..." - это разные ячейки, а также "Электроды" и "Электроды 4 мм" - это тоже разные ячейки, и не учитывать пустые ячейки - такие как B1, B2,.. B14,.. B37). 2. Просуммировать значения для "Электроды" в столбце D (D22+D23+D24) и итог вывести в любой из ячеек (D22,D23,D24), можно во всех вывести. 3. Удалить строки содержащие одинаковые ячейки, но оставить одну (любую) ячейку, отражающую сумму в столбце D.
В прикреплённом файле я использовал цвет - это только для наглядности. Также там имеется второй лист - он содержит вид конечного (желаемого) результата. На единицы измерения не обращайте внимания. Спасибо.
Доброе утро! Нужен макрос 1п. поиска ячеек в столбце B, содержащих строго фиксированный одинаковый текст. 2п. С последующим суммированием значений в ячейках, находящихся справа через одну ячейку. 3п. С последующим удалением строк с одинаковыми ячейками в столбце B, но оставлением той строки в которой выведена сумма подсчитанная в пункте 2.
Я извиняюсь. если не просто всё написал, сейчас расскажу с привязкой к примеру: 1. Найти в столбце B абсолютно одинаковые ячейки содержащие заранее известный мне текст "Электроды", "Эмаль" или "Грунтовка". ("Эмаль" и "Грунт-эмаль..." - это разные ячейки, а также "Электроды" и "Электроды 4 мм" - это тоже разные ячейки, и не учитывать пустые ячейки - такие как B1, B2,.. B14,.. B37). 2. Просуммировать значения для "Электроды" в столбце D (D22+D23+D24) и итог вывести в любой из ячеек (D22,D23,D24), можно во всех вывести. 3. Удалить строки содержащие одинаковые ячейки, но оставить одну (любую) ячейку, отражающую сумму в столбце D.
В прикреплённом файле я использовал цвет - это только для наглядности. Также там имеется второй лист - он содержит вид конечного (желаемого) результата. На единицы измерения не обращайте внимания. Спасибо.Yar4i4
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
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]
или вот без рекордера :) [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
Sub ertert() Dim x, y(), i&, j&, k&, n&, s$ 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) s = x(i, 2) & "~" & x(i, 3) If IsEmpty(.Item(s)) Then k = k + 1 For j = 1 To UBound(x, 2) y(k, j) = x(i, j) Next j .Add Item:=k, Key:=s Else n = .Item(s) 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]
ответ на ЛС вот с учетом ед. изм.
[vba]
Код
Sub ertert() Dim x, y(), i&, j&, k&, n&, s$ 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) s = x(i, 2) & "~" & x(i, 3) If IsEmpty(.Item(s)) Then k = k + 1 For j = 1 To UBound(x, 2) y(k, j) = x(i, j) Next j .Add Item:=k, Key:=s Else n = .Item(s) 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