i found this code for master
www.mrexcel.com
and i try modifay it to suitable for me but its not appear all item in column 8 when the data combining what is the wrong in the code
DanteAmor
combining data in listbox on userform across multiple sheets and calculate values amongst them
hi experts I have many sheets about five sheets contains data are almost 3000 rows for each sheet and it will increase continuiosly . so what I want when run the userform should merge the duplicate items based on COL B across the sheets each sheet repeat the items except the first sheet because...
| sample data.xlsb | |||
|---|---|---|---|
| T | |||
| 13 | |||
SH1 | |||
VBA Code:
Dim lr As Long, sht As Worksheet
Private Sub UserForm_Initialize()
Dim i As Long
lr = lr + Sheets("SH1").Range("A" & Rows.Count).End(3).Row - 1
Set sht = Sheets("Temp")
sht.Range("A1:Q1").Value = Sheets("SH1").Range("A1:Q1").Value
ListBox1.ColumnHeads = True
OptionButton1.Value = True
End Sub
Private Sub CommandButton1_Click()
Dim sh As Worksheet
Dim dic As Object
Dim i As Long, j As Long, k As Long, m As Long
Dim a() As Variant, b As Variant
Set dic = CreateObject("Scripting.dictionary")
sht.Range("A1").Value = "ID"
sht.Range("A:A").NumberFormat = "General"
' sht.Range("I:J").NumberFormat = "#,##0 ""RYAL"""
If OptionButton1 Then
Set sh = Sheets("SH1")
ReDim b(1 To sh.Range("A" & Rows.Count).End(3).Row - 1, 1 To 17)
Call fillarray(dic, sh, b)
Else
b = Sheets("SH1").Range("A2:Q" & Sheets("SH1").Range("A" & Rows.Count).End(3).Row).Value
sht.Range("A1").Value = "DATE"
End If
sht.Range("A2:Q" & Rows.Count).ClearContents
sht.Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
ListBox1.RowSource = sht.Name & "!" & "A2:Q" & sht.Range("A" & Rows.Count).End(3).Row
End Sub
Sub fillarray(dic, sh, b)
Dim a() As Variant
Dim j As Long, k As Long, m As Long, n As Long
Erase a
a = sh.Range("A2:Q" & sh.Range("A" & Rows.Count).End(3).Row).Value
For j = 1 To UBound(a, 1)
If Not dic.exists(a(j, 8)) Then
m = m + 1
n = 1
Else
m = Split(dic(a(j, 8)), "|")(0)
n = Split(dic(a(j, 8)), "|")(1) + 1
End If
dic(a(j, 8)) = m & "|" & n
For k = 1 To UBound(a, 2)
Select Case k
Case 1
b(m, k) = m
Case 2 To 8
b(m, k) = a(j, k)
Case 9
b(m, k) = b(m, k) + a(j, k)
Case 10
b(m, 10) = b(m, 10) + a(j, k)
b(m, k) = b(m, 10) / n
Case 11
b(m, k) = b(m, k) + a(j, k)
Case 12
b(m, 12) = b(m, 12) + a(j, k)
b(m, k) = b(m, 12) / n
Case 13 To 14
b(m, k) = b(m, k) + a(j, k)
Case 15
b(m, 15) = b(m, 15) + a(j, k)
b(m, k) = b(m, 15) / n
Case 16
b(m, 16) = b(m, 16) + a(j, k)
b(m, k) = b(m, 16) / n
Case 17
b(m, k) = a(j, k)
End Select
Next
Next
End Sub
Private Sub CommandButton2_Click()
End Sub
