Comment fusionner et résumer avec excel vba - excel, vba, excel-vba, excel-2007

J'essaie de créer vba pour fusionner la valeur de texte et additionner le montant. Par exemple, j'ai ci-dessous des données

Date         Name            Type       Amount
1 Jan        Test1            A           100
1 Jan        Test1            A           150
2 Jan        Test1            A           110
2 Jan        Test1            A           200
1 Jan        Test1            B           130
1 Jan        Test1            B           110
1 Jan        Test2            B           130
1 Jan        Test2            B           160
1 Jan        Test3            B           180

Le résultat devrait ressembler à ceci

Date         Name            Type       Amount
1 Jan        Test1            A           250
2 Jan        Test1            A           310
1 Jan        Test1            B           240
1 Jan        Test2            B           290
1 Jan        Test3            B           180

J'ai essayé d'utiliser ci-dessous vba mais ne semble pas fonctionner Comment faire la somme / fusion de lignes similaires dans Excel avec VBA?

Réponses:

Vous obtiendrez le résultat souhaité en utilisant une formule SumIf, puis en remplaçant les valeurs de la colonne D et en supprimant les doublons:

Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
"declare and set your worksheet, amend as required
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
"get the last row with data on Column A

ws.Range("E2").FormulaR1C1 = "=SUMIFS(C[-1],C[-4],RC[-4],C[-3],RC[-3],C[-2],RC[-2])"
"add the sumif formula
ws.Range("E2").AutoFill Destination:=Range("E2:E" & LastRow), Type:=xlFillDefault
"fill the formula down to last cell
ws.Columns("E:E").Copy
ws.Columns("E:E").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
"copy and paste as values
ws.Range("D2:D" & LastRow).Delete Shift:=xlToLeft
"remove column D"s values and bring values from Column E into it
ws.Range("$A$1:$G$" & LastRow).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlNo
"remove duplicates
End Sub