```
Dim ws As Worksheet
Dim vA(), vA2(), vA3()
Dim vSum As Double
Dim vR As Long, vN As Long, vN2 As Long, vC As Long
Private Sub TextBox1_Change()
End Sub
Private Sub UserForm_Initialize()
Call AllRows
Call MergeAndSumUnique
'display in the listbox
ListBox1.ColumnCount = 7
ListBox1.List() = vA3
End Sub
Sub AllRows()
Dim vRAll As Long
'calculate the final size
For Each ws In Worksheets
vR = ws.Cells(Rows.Count, "A").End(xlUp).Row - 1
vRAll = vRAll + vR
Next ws
'resize array
ReDim vA(1 To vRAll, 1 To 7)
'fill array
vC = 1
For Each ws In Worksheets
vR = ws.Cells(Rows.Count, "A").End(xlUp).Row
For vN = 2 To vR
vA(vC, 1) = ws.Cells(vN, 1)
vA(vC, 2) = ws.Cells(vN, 2)
vA(vC, 3) = ws.Cells(vN, 3)
vA(vC, 4) = ws.Cells(vN, 4)
vA(vC, 5) = ws.Cells(vN, 5)
vA(vC, 6) = ws.Cells(vN, 6)
vA(vC, 7) = ws.Cells(vN, 7)
vC = vC + 1
Next vN
Next ws
vC = 0
End Sub
Sub MergeAndSumUnique()
Dim vD, vAdded As Long, vMR As Long
'create one dimensional array from column "B"
ReDim vA2(1 To UBound(vA))
For vN = 1 To UBound(vA)
vA2(vN) = vA(vN, 2)
Next vN
'create aray with unique values from column "B"
With CreateObject("Scripting.Dictionary")
For Each vD In vA2
If Not .exists(vD) Then
.Add vD, .Count
End If
Next vD
'create two dimensional array with unique values
vA2 = Application.Transpose(.keys)
'resize new two dimensional array
ReDim vA3(1 To .Count, 1 To 7)
End With
'fill final array
For vN = 1 To UBound(vA2)
For vN2 = 1 To UBound(vA)
'but before, compare unique items with items in the column "B"
'if match, sum duplicate values in the column "D"
If vA2(vN, 1) = vA(vN2, 2) Then
If vMR = 0 Then vMR = vN2
vSum = vSum + vA(vN2, 7)
End If
Next vN2
vA3(vN, 1) = vA(vMR, 1)
vA3(vN, 2) = vA(vMR, 2)
vA3(vN, 3) = vA(vMR, 3)
vA3(vN, 4) = vA(vMR, 4)
vA3(vN, 5) = vA(vMR, 5)
vA3(vN, 6) = vA(vMR, 6)
vA3(vN, 7) = vSum
vSum = 0
vMR = 0
Next vN
End Sub
Sub OneSheetRows()
vR = ws.Cells(Rows.Count, "A").End(xlUp).Row
If Not vR = 1 Then
'resize array
ReDim vA(1 To vR - 1, 1 To 7)
vC = 1
'fill array
For vN = 2 To vR
vA(vC, 1) = ws.Cells(vN, 1)
vA(vC, 2) = ws.Cells(vN, 2)
vA(vC, 3) = ws.Cells(vN, 3)
vA(vC, 4) = ws.Cells(vN, 4)
vA(vC, 5) = ws.Cells(vN, 5)
vA(vC, 6) = ws.Cells(vN, 6)
vA(vC, 7) = ws.Cells(vN, 7)
vC = vC + 1
Next vN
vC = 0
Call MergeAndSumUnique
End If
End Sub
Private Sub sh1_Change()
Set ws = Sheets("sh1")
Call OneSheetRows
ListBox1.List() = vA3
If vR = 1 Then ListBox1.Clear
End Sub
Private Sub fgj1_Change()
Set ws = Sheets("fgj1")
Call OneSheetRows
ListBox1.List() = vA3
If vR = 1 Then ListBox1.Clear
End Sub
Private Sub zxc_Change()
Set ws = Sheets("zxc")
Call OneSheetRows
ListBox1.List() = vA3
If vR = 1 Then ListBox1.Clear
End Sub
```