Страницы: 1
RSS
Объединить одинаковые значения в столбце с суммированием значений в соседних столбцах
 
На "Лист1" на 26.11.2021 имеется список фамилий, в котором эти фамилии повторяются, и напротив каждой из фамилии имеются цифры. Помогите с формулами, чтобы в "Лист2" они собрали список всех фамилий без повторов, при диапазоне B1:B1000 он бы опирался на дату 26.11.2021 ("Лист1" ячейка B14), которая бы опиралась на дату 26.11.2021 ("Лист2" ячейка E2)и брал лишь диапазон ("Лист1" B15:B24). Надеюсь не слишком замудрёно написал. =)
 
Я конечно человек неопытный и делаю как умею, но вроде бы работает.

Вот еще по теме
Код
Sub Обработать()
' Чистим таблицу на листе 2
With Worksheets(2).ListObjects("Таблица2").DataBodyRange
    If .Rows.Count > 1 Then
      .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
    End If
  End With
Worksheets(2).ListObjects("Таблица2").DataBodyRange.Rows(1).ClearContents
' Основной код
myDate = Worksheets(2).Range("E2").Value
arr = Worksheets(1).Range("B1:C1000").Value
For i = 1 To UBound(arr)
If arr(i, 1) = myDate Then
myRow = i + 1
Exit For
End If
Next i
lLastRow = Cells(myRow, 2).End(xlDown).Row
a = Worksheets(1).Range(Cells(myRow, 2), Cells(lLastRow, 3)).Value
Set sd = CreateObject("Scripting.Dictionary")
For i2 = 1 To UBound(a)
    If sd.Exists(a(i2, 1)) Then
       sd.Item(a(i2, 1)) = sd.Item(a(i2, 1)) + a(i2, 2)
    Else
       sd.Item(a(i2, 1)) = a(i2, 2)
    End If
Next i2
Sheets("Лист2").Range("B3").Resize(sd.Count) = Application.Transpose(sd.keys)
Sheets("Лист2").Range("C3").Resize(sd.Count) = Application.Transpose(sd.items)
End Sub

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

Код
Sub Обработать()
Dim Uniq As New Collection, Lastrow As Long, i As Long, j As Long, Arr(), Arr2()
'Delete all table rows except first row
  With Worksheets(2).ListObjects("Таблица2").DataBodyRange
    If .Rows.Count > 1 Then
      .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
    End If
  End With
'Clear out data from first table row
Worksheets(2).ListObjects("Таблица2").DataBodyRange.Rows(1).ClearContents
myDate = Worksheets(2).Range("E1").Value
'Вот здесь нужно Range сменить если столбцов больше
arr4 = Worksheets(1).Range("B1:D1000").Value
For i = 1 To UBound(arr4)
If arr4(i, 1) = myDate Then
myRow = i + 1
Exit For
End If
Next
Lastrow = Cells(myRow, 2).End(xlDown).Row
Arr = Range(Cells(myRow, 2), Cells(Lastrow, 4)).Value  ' меняем 4 на номер крайнего столбца
    For i = 1 To UBound(Arr, 1)
        On Error Resume Next
        Uniq.Add Arr(i, 1), CStr(Arr(i, 1))
    Next
    ReDim Arr2(1 To Uniq.Count, 1 To 3) ' 1 To 3 меняем 3 на число столбцов
    For i = 1 To Uniq.Count
        For j = 1 To UBound(Arr, 1)
            If Arr(j, 1) = Uniq(i) Then
                Arr2(i, 1) = Uniq(i)
                Arr2(i, 2) = Arr2(i, 2) + Arr(j, 2)
                Arr2(i, 3) = Arr2(i, 3) + Arr(j, 3)
                ' сюда добавить Arr2(i, 4.....n)= Arr2(i, 4) + Arr(j, 4) сколько нужно будет это будет суммироваться четвертый столбец и далее
            End If
        Next
    Next
    Worksheets(2).Select
    Range(Cells(3, 2), Cells(Uniq.Count + 2, 4)) = Arr2 ' меняем 4 число столбцов +1 или номер крайнего столбца в таблице куда данные размещаешь
End Sub

Файл 125
Изменено: Семен Фадеев - 29.11.2021 14:50:40
 
Anton Klashkin, pq:
Код
let
    Source = Excel.Workbook(Web.Contents("https://www.planetaexcel.ru/bitrix/components/bitrix/forum.interface/show_file.php?fid=469718&action=download")){[Item="Лист1",Kind="Sheet"]}[Data],
    a = Table.FillDown(Table.AddColumn(Source, "q", each try [Column1] as date otherwise null), {"q"}),
    b = Table.SelectRows(a, each [Column2] <> null and [q] = Excel.Workbook(Web.Contents("https://www.planetaexcel.ru/bitrix/components/bitrix/forum.interface/show_file.php?fid=469718&action=download")){[Item="Лист2",Kind="Sheet"]}[Data]{0}[Column4]),
    c = Table.Group(b, {"Column1"}, {"E", each List.Sum([Column2])})
in
    c
 
Anton Klashkin, еще вариант
Код
Sub mrshkei()
Dim arr, arr2, i As Long, n As Long, lr As Long, col As New Collection, sh As Worksheet, sh2 As Worksheet
Set sh = Worksheets("Лист1"): Set sh2 = Worksheets("Лист2")
lr = sh.Cells(Rows.Count, 2).End(xlUp).Row + 1: d = sh2.Cells(2, 5): arr = sh.Range("B2:C" & lr)
    For i = LBound(arr) To UBound(arr)
        If IsDate(arr(i, 1)) And arr(i, 1) = d Then
            For n = i + 1 To UBound(arr)
            If arr(n, 1) <> Empty Then
                On Error Resume Next
                col.Add arr(n, 1), arr(n, 1)
                On Error GoTo 0
            Else
                GoTo M
            End If
            Next n
        End If
    Next i
M:
If i = lr Then MsgBox "DATE NOT FOUND": Exit Sub
ReDim arr2(1 To col.Count, 1 To 2)
For k = 1 To col.Count
    arr2(k, 1) = col(k)
    arr2(k, 2) = Application.WorksheetFunction.SumIf(sh.Range(sh.Cells(i + 1, 2), sh.Cells(n, 2)), col(k), sh.Range(sh.Cells(i + 1, 3), sh.Cells(n, 3)))
Next k
sh2.Range("B:C").ClearContents: sh2.Range("B3").Resize(UBound(arr2), 2) = arr2
End Sub
Не бойтесь совершенства. Вам его не достичь.
 
Семен Фадеев, попробуйте очищать ListObject таким способом

Код
    With Worksheets(2).ListObjects(1)
        If .ListRows.Count > 1 Then
            .DataBodyRange.Rows.Delete
        End If
    End With
 
Цитата
написал:
попробуйте очищать ListObject таким способом
Спасибо, приму к сведению.
 

В формулах плохо разбираюсь ещё вариант макросом

Код
Sub SENdfg(): Dim Rg1 As Range, DatPo, Arr1, Dic1
Set Dic1 = CreateObject("scripting.dictionary")
Set Rg1 = Worksheets(1).UsedRange
DatPo = Worksheets(2).Range("E2")
Set Rg1 = Rg1.Find(DatPo, , xlFormulas, xlWhole).CurrentRegion
Arr1 = Rg1.Value
    For i = 2 To UBound(Arr1)
If Not Dic1.exists(Arr1(i, 1)) Then Dic1(Arr1(i, 1)) = Arr1(i, 2) Else _
Dic1(Arr1(i, 1)) = Dic1(Arr1(i, 1)) + Arr1(i, 2)
    Next i
Range("B3").Resize(Dic1.Count) = WorksheetFunction.Transpose(Dic1.keys)
Range("C3").Resize(Dic1.Count) = WorksheetFunction.Transpose(Dic1.Items)
End Sub
 
Цитата
New: If .ListRows.Count > 1
приветствую!
> 0, потому что 1 строка С информацией тоже нуждается в очистке, а вот 1 строка БЕЗ информации это .ListRows.Count = 0 или .DataBodyRange Is Nothing  ;)
Изменено: Jack Famous - 30.11.2021 10:10:36
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Цитата
Jack Famous, написал:
приветствую!
И Вам привет, просто для первой строки у меня отдельная строка кода!) поэтому, Я полагаю Меня поправили именно так.
Изменено: Семен Фадеев - 30.11.2021 12:56:02
 
Формула.
Код
=SUMPRODUCT((LOOKUP(ROW($B$2:$B$1000);(ROW($B$2:$B$1000)/ISNUMBER(Лист1!$B$2:$B$1000)/(Лист1!$B$2:$B$1000>0));Лист1!$B$2:$B$1000=$E$2)*(Лист1!$B$2:$B$1000=B3)*Лист1!$C$2:$C$1000))

Для уникальных имен. (Массивная вводить через CTRL+SHIFT+ENTER)
Код
=IFERROR(INDEX(Лист1!$B$2:$B$100;MATCH(1;(COUNTIF($B$2:B2;Лист1!$B$2:$B$100)=0)/ISTEXT(Лист1!$B$2:$B$100);));"")

Ограничение. В столбце с именами кроме дат не должно быть никаких других чисел, иначе формула будет считать некорректно.
Изменено: memo - 30.11.2021 20:18:53
 
и что если цифры кроме дат еще будет на что повлияет я не увидел разницы
 
Цитата
Тимофеев написал:
не увидел разницы
В столбце с датой 26/11/2021 замените, скажем, Сидорова на любое число и сравните результат с предыдущим.
Страницы: 1
Наверх