Подсчет и суммирование уникальных данных в нескольких столбцах, затем сопоставление с другими уникальными данными

Question

Это вопрос с добавлением my previous post. Мне не удалось найти способ понять это в течение нескольких часов, а также не найти идею из онлайн-поиска.

Предположим, что у меня есть следующие данные (фактические данные могут быть тысячи или миллионы) в листе Excel (таблица 1):

Name Entry No. ID Expense 1 Expense 2 
A  1  A1  14   5 
B  2  B4  12   7 
B  2  B5  20   8 
C  3  C0  19   7 
D  4  -  0   0 
A  1  A1  11   6 
A  1  A2  20   5 
E  5  -  0   0 
F  6  -  0   0 
C  3  C0  15   5 
B  2  B5  20   4 
B  2  B5  16   3 
B  2  B5  12   7 
B  2  B6  18   8 
A  1  A1  10   1 
A  1  A1  14   7 
A  1  A2  10   2 
B  2  B3  13   7 
B  2  B3  14   1 
B  2  B3  11   4 

Символ (-) в столбце No. ID выше, может быть также номер 0 или пустую ячейку.

Я хочу форматировать вышеуказанные данные следующим образом (таблица 2)

Name Entry No. ID Number of ID Sum of Expense 1 Sum of Expense 2 
A  1  A1  2    49     19 
A  1  A2  2    30     7 
B  2  B3  4    38     12 
B  2  B4  4    12     7 
B  2  B5  4    68     22 
B  2  B6  4    18     8 
C  3  C0  1    34     12 
D  4  -  0    0     0 
E  5  -  0    0     0 
F  6  -  0    0     0 

номер столбца ID означает А имеет 2 идентификаторы (A1 и A2), В имеет 4 идентификаторы (В1, В2, В3, и B4), C имеет 1 ID (C0), а D, E и F не имеют идентификатора. Столбец Сумма затрат 1 и 2 - сумма всех расходов за каждый нет. Я БЫ.

Лучшее, что я могу получить с помощью сводной таблицы, как это

Как один выполнить задачу, как в таблице 2 в MS Excel? Если возможно, скрипт VBA.

Answer 1

Этот код после изменений работает при запуске его из того же Рабочая книга (не имеет значения, какая рабочая таблица).

Добавлен массив для динамического добавления номера Сумма расходов.

Этот код охватывает логику, необходимую для преобразования данных таблицы так, как вы хотели.

Sub OrganizeTable() 

Dim TableArray()      As Variant 
Dim i, j, k, i_tmp, LastRow    As Long 
Dim Sum_Count       As Integer 
Dim SheetData, SheetResult    As Excel.Worksheet 
Dim StringTemp       As String 
Dim LongMin, LongMax     As Long 
Dim SumExpense()      As Long 
Dim Number_of_ID      As Long 
Dim Number_of_Expense_Type    As Integer 

' Number_of_Expense_Type = number of expense type you have in your 
Number_of_Expense_Type = InputBox("Enter number of expense type ", "Expense Type counter") 

Set SheetData = ActiveWorkbook.Worksheets("Sheet1") 
LastRow = SheetData.Cells(SheetData.Rows.Count, "A").End(xlUp).row 
Set SheetResult = ActiveWorkbook.Worksheets("Sheet2") 
Erase TableArray 

ReDim TableArray(1 To LastRow - 1, 1 To 3 + Number_of_Expense_Type) ' create array with exact number of Project names 
ReDim SumExpense(1 To Number_of_Expense_Type) 
i = 2 
' insert all table's data into multi-dimensional array (easier and faster to manipulate later) 
While SheetData.Cells(i, 1) <> "" 
    For j = 1 To 3 + Number_of_Expense_Type 
     TableArray(i - 1, j) = SheetData.Cells(i, j) 
    Next 
    i = i + 1 
Wend 


LongMin = LBound(TableArray()) 
LongMax = UBound(TableArray()) 

' this loop is for sorting the array according to Name, and then No. ID 
For i = LongMin To LongMax - 1 
    For j = i + 1 To LongMax 
     ' 1st rule: check for Name Value in Column A 
     If TableArray(i, 1) > TableArray(j, 1) Then 
      For k = 1 To 3 + Number_of_Expense_Type 
       StringTemp = TableArray(i, k) 
       TableArray(i, k) = TableArray(j, k) 
       TableArray(j, k) = StringTemp 
      Next 
     End If 
     ' 2nd rule: check for No. ID in Column c 
     If TableArray(i, 1) = TableArray(j, 1) And TableArray(i, 3) > TableArray(j, 3) Then 
      For k = 1 To 3 + Number_of_Expense_Type 
       StringTemp = TableArray(i, k) 
       TableArray(i, k) = TableArray(j, k) 
       TableArray(j, k) = StringTemp 
      Next 
     End If 

    Next 
Next 


i = 1 
j = 2 ' this is the Row number where the sorted table will start 
k = 1 ' this is the Column number where the sorted table will start 
While i <= LongMax 
    SheetResult.Cells(j, k) = TableArray(i, 1) 
    SheetResult.Cells(j, k + 1) = TableArray(i, 2) 
    SheetResult.Cells(j, k + 2) = TableArray(i, 3) 

    For Sum_Count = 1 To Number_of_Expense_Type 
     SumExpense(Sum_Count) = TableArray(i, 4 + Sum_Count - 1) 
    Next 

    ' this IF and WHILE loop are for accumulating the Sum Expense 1 and Sum Expense 2 for the same ID type 
    If i + 1 <= LongMax Then 
     While TableArray(i, 3) = TableArray(i + 1, 3) And TableArray(i, 1) = TableArray(i + 1, 1) 

      For Sum_Count = 1 To Number_of_Expense_Type 
       SumExpense(Sum_Count) = SumExpense(Sum_Count) + Val(TableArray(i + 1, 4 + Sum_Count - 1)) 
      Next 

      i = i + 1 
     Wend 
    End If 

    ' this IF and WHILE loop are for counting how many Num of ID you have per Name 
    Number_of_ID = 0 
    If TableArray(i, 3) <> "-" Then 
     Number_of_ID = 1 
     For i_tmp = 1 To LongMax - 1 
      While Cells(j, k) = TableArray(i_tmp + 1, 1) And TableArray(i_tmp, 1) = TableArray(i_tmp + 1, 1) And TableArray(i_tmp, 3) <> TableArray(i_tmp + 1, 3) 
       Number_of_ID = Number_of_ID + 1 
       i_tmp = i_tmp + 1 
      Wend 
     Next 
    Else 
     Number_of_ID = 0 
    End If 

    SheetResult.Cells(j, k + 3) = Number_of_ID 

    For Sum_Count = 1 To Number_of_Expense_Type 
     SheetResult.Cells(j, k + 4 + Sum_Count - 1) = SumExpense(Sum_Count) 
     SumExpense(Sum_Count) = 0 
    Next 

    Number_of_ID = 0 
    j = j + 1 
    i = i + 1 
Wend 

' writing down the headers for you table 
SheetResult.Cells(1, k) = "Name" 
SheetResult.Cells(1, k + 1) = "Entry" 
SheetResult.Cells(1, k + 2) = "No. ID" 
SheetResult.Cells(1, k + 3) = "Number of ID" 

For Sum_Count = 1 To Number_of_Expense_Type 
    SheetResult.Cells(1, k + 4 + Sum_Count - 1) = "Sum of Expense " & Sum_Count 
Next 

Set SheetData = Nothing 
Set SheetResult = Nothing 

End Sub 

Answer 2

У вас может быть VBA для копирования данных сводной таблицы и вставки ее в качестве обычной таблицы.

Answer 3

Ниже кода может помочь:

Предположения:

1. Ваши данные в ActiveSheet
2. Результат будет отображаться в Sheet2

Sub Demo() 
    Dim dict1 As Object, dict2 As Object 
    Dim c1 As Variant, c2 As Variant 
    Dim i As Long, lastRow As Long, targetRow As Long, count As Long 
    Dim targetWS As Worksheet 

    Set targetWS = ThisWorkbook.Sheets("Sheet2") 
    Set dict1 = CreateObject("Scripting.Dictionary") 
    Set dict2 = CreateObject("Scripting.Dictionary") 

    'get last row with data 
    lastRow = Cells(Rows.count, "A").End(xlUp).Row 

    'assign unique values in Column A (Name) to dict1 
    c1 = Range("A2:A" & lastRow) 
    For i = 1 To UBound(c1, 1) 
     dict1(c1(i, 1)) = 1 
    Next i 

    'assign unique values in Column C (No. Id) to dict2   
    c2 = Range("C2:C" & lastRow) 
    For i = 1 To UBound(c2, 1) 
     dict2(c2(i, 1)) = 1 
    Next i 

    'write headers in Sheet2 
    targetWS.Cells(1, 1) = "Name" 
    targetWS.Cells(1, 2) = "Entry" 
    targetWS.Cells(1, 3) = "No. Id" 
    targetWS.Cells(1, 4) = "Number of ID" 
    targetWS.Cells(1, 5) = "Sum of Expense 1" 
    targetWS.Cells(1, 6) = "Sum of Expense 2" 

    'fill data in table   
    targetRow = 2 '-->targetRow will keep the counter for new row in Sheeet2 

    'loop through unique values of Name through dict1 
    For Each k1 In dict1.Keys 
     count = 0 
     'loop through unique No. ID through dict2 to match values in dict1 and dict2 
     For Each k2 In dict2.Keys 
      If k2 Like k1 & "*" Then '-->match values of dict1 and dict2 
       count = count + 1 
       'fill data in table if match found 
       targetWS.Cells(targetRow, 1) = k1 
       targetWS.Cells(targetRow, 3) = k2 
       targetWS.Cells(targetRow, 4) = dict2(k2) 
       targetWS.Cells(targetRow, 5) = Application.WorksheetFunction.SumIf(Range("C2:C" & lastRow), k2, Range("D2:D" & lastRow)) 
       targetWS.Cells(targetRow, 6) = Application.WorksheetFunction.SumIf(Range("C2:C" & lastRow), k2, Range("E2:E" & lastRow)) 
       targetRow = targetRow + 1 
      End If 
     Next k2 

     'fill data if no match found 
     If count = 0 Then 
      targetWS.Cells(targetRow, 1) = k1 
      targetWS.Cells(targetRow, 3) = "-" 
      targetWS.Cells(targetRow, 5) = 0 
      targetWS.Cells(targetRow, 6) = 0 
      targetRow = targetRow + 1 
     End If 
    Next k1 

    'get values for Entry and Number of ID 
    For i = 2 To targetWS.Cells(Rows.count, "A").End(xlUp).Row 
     targetWS.Cells(i, 2) = Range("A:A").Find(What:=targetWS.Cells(i, 1), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True).Offset(0, 1).Value 
     targetWS.Cells(i, 4) = Application.WorksheetFunction.CountIf(targetWS.Range("A1:A" & lastRow), targetWS.Cells(i, 1)) 
    Next i 
End Sub 

Примечание: Приведенный выше код не будет отображать данные в порядке возрастания, как A1-A2-B3-B4-B5-B6-C0 вместо данных будут отображаться в порядке их появления, как A1-A2-B4-B5-B6-B3-C0

См изображение для справки: