计算并汇总几列中的唯一数据，然后将其与另一个唯一数据进行匹配

这是我以前的post的另一个问题。 我无法find一个方法来找出几个小时，也没有从网上searchfind一个想法。

假设我在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 

上面的列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的ID号表示A有2个ID（A1和A2），B有4个ID（B1，B2，B3和B4），C有1个ID（C0），D，E和F没有ID。 费用1和2的总和是所有费用的总和。 ID。

我可以通过使用Pivot Table获得最好的结果

如何在MS Excel中执行类似于表2的任务？ 如果可能的话，它的VBA脚本。

Answer 1

从相同的工作簿运行时，此代码修改后工作（不要紧，哪个工作表）。

添加了一个数组到dynamic添加数量总和的费用types。

此代码涵盖了将表格数据转换为您所需的逻辑。

 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

以下代码可能有所帮助

假设：

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的外观顺序显示数据

见图像以供参考：

Answer 3

您可以让VBA复制数据透视表数据并将其作为普通表粘贴。