Объединить строки & Sum значений в рабочем листе

Обновить

April 2019

Просмотры

866 раз

1

У меня есть Excel лист с ниже (трубы «|», чтобы разграничивать столбцы) данных.

A|B|C|X|50|60
D|E|F|X|40|30
A|B|C|X|10|20
A|B|C|Y|20|20
A|B|C|X|20|70
D|E|F|X|10|50
A|B|C|Y|10|10

В результате я пытаюсь получить это:

A|B|C|X|80|150
A|B|C|Y|30|30
D|E|F|X|50|80

Значения A, B, C и D, E, F, как уникальные идентификаторы. На самом деле только А или D могут быть рассмотрены. Значения X и Y, как «типы», и целые числа приведены значения суммы. Этот образец был упрощен, есть тысячи уникальных идентификаторов, десятки типов и десятка значений суммы. Строки не сортируется, типы могут быть расположены в более высоких или более низких рядах. Я пытаюсь избежать использования сводной таблицы.

Dim LastRow As Integer
Dim LastCol As Integer
Dim i As Integer

LastCol = Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
LastRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row

For i = 1 To LastRow
????
Next i

Код выше добирается до точки пробегает по строкам, но я не ясно о том, что после этой точки.

1 ответы

1
  1. Sort them on all alphabetic columns you deem important.
  2. In an unused column to the right use a formula like the following in the second row,

    =IF($A2&$B2&$C2&$D2=$A3&$B3&$C3&$D3, "", SUMIFS(E:E,$A:$A, $A2,$B:$B, $B2,$C:$C, $C2,$D:$D, $D2))

  3. Copy that formula right one column then fill both columns down as far as your data goes

  4. Filter on the two columns, removing blanks.

            radiations measurements from a PRM-9000

  5. Optionally copy the data to a new report worksheet and remove columns E & F.

Addendum:

A more automated approach could be achieved with some form of array and some simple mathematical operations. I've chosen a dictionary object in order to take use of its indexed Key to recognize patterns in the first four alphabetic identifiers.

To use a scripting dictionary, you need to go into the VBE's Tools ► References and add Microsoft Scripting Runtime. The following code will not compile without it.

The following has been adjusted for dynamic columns of keys and integers.

Sub rad_collection()
    Dim rw As Long, nc As Long, sTMP As String, v As Long, vTMP As Variant
    Dim i As Long, iNumKeys As Long, iNumInts As Long
    Dim dRADs As New Scripting.Dictionary

    dRADs.CompareMode = vbTextCompare
    iNumKeys = 5    'possibly calculated by num text (see below)
    iNumInts = 2    'possibly calculated by num ints (see below)

    With ThisWorkbook.Sheets("Sheet4").Cells(1, 1).CurrentRegion
        'iNumKeys = Application.CountA(.Rows(2)) - Application.Count(.Rows(2))  'alternate count of txts
        'iNumInts = Application.Count(.Rows(2))    'alternate count of ints
        For rw = 2 To .Cells(Rows.Count, 1).End(xlUp).row
                vTMP = .Cells(rw, 1).Resize(1, iNumKeys).Value2
                sTMP = Join(Application.Index(vTMP, 1, 0), Chr(183))
                If Not dRADs.Exists(sTMP) Then
                    dRADs.Add Key:=sTMP, Item:=Join(Application.Index(.Cells(rw, iNumKeys + 1).Resize(1, iNumInts).Value2, 1, 0), Chr(183))
                Else
                    vTMP = Split(dRADs.Item(sTMP), Chr(183))
                    For v = LBound(vTMP) To UBound(vTMP)
                        vTMP(v) = vTMP(v) + .Cells(rw, iNumKeys + 1 + v).Value2
                    Next v
                    dRADs.Item(sTMP) = Join(vTMP, Chr(183))
                End If

        Next rw

        rw = 1
        nc = iNumKeys + iNumInts + 1
        .Cells(rw, nc + 1).CurrentRegion.ClearContents  'clear previous
        .Cells(rw, nc + 1).Resize(1, nc - 1) = .Cells(rw, 1).Resize(1, nc - 1).Value2
        For Each vTMP In dRADs.Keys
            'Debug.Print vTMP & "|" & dRADs.Item(vTMP)
            rw = rw + 1
            .Cells(rw, nc + 1).Resize(1, iNumKeys) = Split(vTMP, Chr(183))
            .Cells(rw, nc + iNumKeys + 1).Resize(1, iNumInts) = Split(dRADs.Item(vTMP), Chr(183))
            .Cells(rw, nc + iNumKeys + 1).Resize(1, iNumInts) = _
              .Cells(rw, nc + iNumKeys + 1).Resize(1, iNumInts).Value2
        Next vTMP
    End With

    dRADs.RemoveAll: Set dRADs = Nothing

End Sub

Just run the macro against the numbers you have provided as samples. I've assumed some form of column header labels in the first row. The dictionary object is populated and duplicates in the combined identifiers have their numbers summed. All that is left is to split them back up and return them to the worksheet in an unused area.

    Rad measurement collection

Location of Microsoft Scripting Runtime - In the Visual Basic Editor (aka VBE) choose Tools ► References (Alt+T,R) and scroll down a little more than halfway to find it.

        Microsoft Scripting Runtime