Dim ws As Worksheet
Dim vA(), vA2(), vA3()
Dim vR As Long, vC As Long
Private Sub UserForm_Initialize()
Call AllMergedRows
Call SetListBoxColumnWidths
End Sub
Sub AllMergedRows()
Call AllRows
Call MergeAndSumUnique
'display in the listbox
ListBox1.ColumnCount = 9
ListBox1.List() = vA3
End Sub
Sub AllRows()
vRAll = 0
'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, 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 9)
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)
'another value calculation ( columns 8 & 9 )
vSum2 = vSum2 + vA(vN2, 7)
'count the number of the calculations
vNC = vNC + 1
'separating text from number
vInv = Split(vA(vN2, 5), "-")(0)
vNInv = Split(vA(vN2, 5), "-")(1)
vInv2 = Split(vA(vN2, 6), "-")(0)
vNInv2 = Split(vA(vN2, 6), "-")(1)
'create string from numbers
vS = vS & vNInv & ","
vS2 = vS2 & vNInv2 & ","
End If
Next vN2
'edit final string
vS = vInv & "-" & Left(vS, Len(vS) - 1)
vS2 = vInv2 & "-" & Left(vS2, Len(vS2) - 1)
vA3(vN, 1) = vA(vMR, 1)
vA3(vN, 2) = vA(vMR, 2)
vA3(vN, 3) = vA(vMR, 3)
vA3(vN, 4) = vA(vMR, 4)
'display new string
vA3(vN, 5) = vS
vA3(vN, 6) = vS2
vA3(vN, 7) = vSum
'display calculation in the specific decimal format
vA3(vN, 8) = Format(vSum2 / vNC, "0.00")
vA3(vN, 9) = Format(vA3(vN, 7) * vA3(vN, 8), "0.00")
vSum = 0
vSum2 = 0
vNC = 0
vMR = 0
vS = ""
vS2 = ""
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
Sub SetListBoxColumnWidths()
'don't forget to add label on the userform
With Label1
'copy some listbox properties to label properties
.FontSize = ListBox1.FontSize
.Font.Bold = ListBox1.Font.Bold
'set label to autosize mode
.AutoSize = True
'make label to be in one line
.WordWrap = False
'optional, hide label
.Top = -100
End With
'loop through listbox items
With ListBox1
For vN = 0 To .ColumnCount - 1
For vN2 = 0 To .ListCount - 1
'use label to calculate max width
Label1.Caption = .List(vN2, vN)
'keep max width
If Label1.Width > vMaxWidth Then _
vMaxWidth = Label1.Width
Next vN2
vW = vW & vMaxWidth + 10 & ","
vMaxWidth = 0
Next vN
' trim ColumnWidths and display...
.ColumnWidths = Left(vW, Len(vW) - 1)
End With
End Sub
Sub FillListBox()
Call OneSheetRows
ListBox1.List() = vA3
If vR = 1 Then ListBox1.Clear
End Sub
Private Sub sh1_Change()
Set ws = Sheets("sh1")
Call FillListBox
End Sub
Private Sub fgj1_Change()
Set ws = Sheets("fgj1")
Call FillListBox
End Sub
Private Sub zxc_Change()
Set ws = Sheets("zxc")
Call FillListBox
End Sub
Private Sub CommandButton1_Click()
Call AllMergedRows
End Sub