Collection and calculation columns on userform across sheets

Hasson

Active Member
Joined
Apr 8, 2021
Messages
409
Office Version
  1. 2016
Platform
  1. Windows
Hi,
I would merge amounts in TOTAL column for each sheet if textbox1, textbox2 are empty , if there are dates then merge within dates .
every sheet contains about 13000 rows so should show ITEM,BATCH ,ID, sheets names as headers from column 4 in list box , as to last column will calculate like this =BBR-BMTR+VSR-STR
and insert TOTAL row to sum TOTAL column in listbox.
Hasson (1) (4).xlsm
ABCDEFG
1DATEBATCHINVOICIDQTYUNIT PRICETOTAL
201/01/2023AVV00VVT/009FOOILLL-100220.00110.0024,200.00
301/01/2023AVV01VVT/009FOOILLL-101100.00140.0014,000.00
401/01/2023AVV02VVT/009FOOILLL-102110.00200.0022,000.00
501/01/2023AVV03VVT/009FOOILLL-103340.00120.0040,800.00
602/01/2023AVV01VVT/010FOOILLL-101120.00155.0018,600.00
702/01/2023AVV00VVT/010FOOILLL-10060.00160.009,600.00
803/01/2023AVV03VVT/011FOOILLL-10360.00155.009,300.00
903/01/2023AVV01VVT/011FOOILLL-10160.00175.0010,500.00
1003/01/2023AVV00VVT/011FOOILLL-10060.00144.008,640.00
1103/01/2023AVV04VVT/011FOOILLL-10422.00134.002,948.00
1203/01/2023AVV05VVT/011FOOILLL-10560.00133.007,980.00
BBR
Cell Formulas
RangeFormula
G2:G12G2=E2*F2





Hasson (1) (4).xlsm
ABCDEFG
1DATEBATCHINVOICIDQTYUNIT PRICETOTAL
201/02/2023AVV00SDFF/99FOOILLL-10010.00150.001,500.00
302/02/2023AVV01SDFF/99FOOILLL-10110.00160.001,600.00
403/02/2023AVV02SDFF/100FOOILLL-10220.00220.004,400.00
504/02/2023AVV03SDFF/101FOOILLL-10315.00150.002,250.00
605/02/2023AVV01SDFF/102FOOILLL-10112.00180.002,160.00
706/02/2023AVV00SDFF/103FOOILLL-1005.00170.00850.00
807/02/2023AVV03SDFF/104FOOILLL-1039.00185.001,665.00
908/02/2023AVV01SDFF/105FOOILLL-1018.00166.001,328.00
1009/02/2023AVV00SDFF/106FOOILLL-1004.00177.00708.00
1109/02/2023AVV02SDFF/106FOOILLL-10220.00212.004,240.00
1210/02/2023AVV05SDFF/107FOOILLL-1055.00145.00725.00
BMTR
Cell Formulas
RangeFormula
G2:G12G2=E2*F2



Hasson (1) (4).xlsm
ABCDEFG
1DATEBATCHINVOICIDQTYUNIT PRICETOTAL
215/02/2023AVV00VBN/900-90FOOILLL-10010.00110.001,100.00
316/02/2023AVV01VBN/900-91FOOILLL-10110.00140.001,400.00
417/02/2023AVV01VBN/900-92FOOILLL-10112.00200.002,400.00
518/02/2023AVV00VBN/900-93FOOILLL-1005.00120.00600.00
619/02/2023AVV03VBN/900-94FOOILLL-1039.00155.001,395.00
720/02/2023AVV01VBN/900-95FOOILLL-1018.00144.001,152.00
821/02/2023AVV00VBN/900-96FOOILLL-1004.00175.00700.00
922/02/2023AVV04VBN/900-97FOOILLL-1042.00140.00280.00
1023/02/2023AVV04VBN/900-98FOOILLL-1042.00144.00288.00
VSR
Cell Formulas
RangeFormula
G2:G10G2=E2*F2



Hasson (1) (4).xlsm
ABCDEFG
1DATEBATCHINVOICIDQTYUNIT PRICETOTAL
228/02/2023AVV00FGRT500-00FOOILLL-1005.00150.00750.00
301/03/2023AVV01FGRT500-00FOOILLL-1015.00160.00800.00
402/03/2023AVV02FGRT500-00FOOILLL-1025.00220.001,100.00
503/03/2023AVV03FGRT500-00FOOILLL-10310.00150.001,500.00
604/03/2023AVV03FGRT500-01FOOILLL-1038.00166.001,328.00
705/03/2023AVV03FGRT500-02FOOILLL-1034.00177.00708.00
806/03/2023AVV01FGRT500-03FOOILLL-1014.00190.00760.00
STR
Cell Formulas
RangeFormula
G2:G8G2=E2*F2




should be on form
hss1.JPG


thanks
 
Try this.
Columns AA to AG are temporarily required to sort the data, eventually the data is removed from those columns.

Test the performance with all your data and let me know.

VBA Code:
Dim c As Variant

Private Sub Textbox1_Change()
  Call FilterData
End Sub
Private Sub Textbox2_Change()
  Call FilterData
End Sub

Private Sub FilterData()
  Dim tb1 As Date, tb2 As Date
  Dim i As Long, j As Long, k As Long, y As Long, nRow As Long
  Dim b As Variant, d As Variant, ky As Variant
  Dim dic As Object
  Dim t1 As Double, t2 As Double, t3 As Double, t4 As Double
 
  'Date validation
  If Len(TextBox1.Value) <> 10 And TextBox1.Value <> "" Then Exit Sub
  If Len(TextBox2.Value) <> 10 And TextBox2.Value <> "" Then Exit Sub
  If Not IsDate(TextBox1.Value) And TextBox1.Value <> "" Then Exit Sub
  If Not IsDate(TextBox2.Value) And TextBox2.Value <> "" Then Exit Sub
  If TextBox1.Value <> "" And TextBox2.Value = "" Then Exit Sub
  If TextBox1.Value = "" And TextBox2.Value <> "" Then Exit Sub
  If TextBox1.Value <> "" And TextBox2.Value <> "" Then
    If CDate(TextBox2.Value) < CDate(TextBox1.Value) Then
      MsgBox "The end date is less than the start date"
      Exit Sub
    End If
  End If
  
  'Prepare listbox
  Set dic = CreateObject("Scripting.Dictionary")
  ListBox1.Clear
  ReDim b(1 To UBound(c, 1), 1 To UBound(c, 2))
  ReDim d(1 To UBound(c, 1), 1 To 8)
  d(1, 1) = "ITEM"
  d(1, 2) = "BATCH"
  d(1, 3) = "ID"
  d(1, 4) = "BBR"
  d(1, 5) = "BMTR"
  d(1, 6) = "BMTR"
  d(1, 7) = "VSR"
  d(1, 8) = "TOTAL"
  y = 1
 
  'Data processing
  For i = 2 To UBound(c)
    If TextBox1.Value = "" Then tb1 = CDate(c(i, 1)) Else tb1 = CDate(TextBox1.Value)
    If TextBox2.Value = "" Then tb2 = CDate(c(i, 1)) Else tb2 = CDate(TextBox2.Value)
    If CDate(c(i, 1)) >= tb1 And CDate(c(i, 1)) <= tb2 Then
      ky = c(i, 3) '& "|" & b(k, 4)
      If Not dic.exists(ky) Then
        y = y + 1
        dic(ky) = y
      End If
      nRow = dic(ky)
      d(nRow, 1) = nRow - 1
      d(nRow, 2) = c(i, 2)
      d(nRow, 3) = c(i, 3)
      d(nRow, 4) = d(nRow, 4) + c(i, 4) 'Format(b(k, 4), "#,##0.00;;-")
      d(nRow, 5) = d(nRow, 5) + c(i, 5)
      d(nRow, 6) = d(nRow, 6) + c(i, 6)
      d(nRow, 7) = d(nRow, 7) + c(i, 7)
      d(nRow, 8) = d(nRow, 4) - d(nRow, 5) + d(nRow, 6) - d(nRow, 7)
      t1 = t1 + c(i, 4)
      t2 = t2 + c(i, 5)
      t3 = t3 + c(i, 6)
      t4 = t4 + c(i, 7)
    End If
  Next
  For i = 2 To dic.Count + 1
    d(i, 4) = Format(d(i, 4), "#,##0.00;;-")
    d(i, 5) = Format(d(i, 5), "#,##0.00;;-")
    d(i, 6) = Format(d(i, 6), "#,##0.00;;-")
    d(i, 7) = Format(d(i, 7), "#,##0.00;;-")
    d(i, 8) = Format(d(i, 8), "#,##0.00;;-")
  Next
  
  d(dic.Count + 2, 1) = "TOTAL"
  d(dic.Count + 2, 8) = Format(t1 - t2 + t3 - t4, "#,##0.00;;-")
 
  'Output
  ListBox1.List = d
End Sub

Private Sub UserForm_Activate()
  Dim i As Long, nMax As Long, k As Long
  Dim sh As Worksheet
  Dim arr As Variant, itm As Variant
  Dim a As Variant, b As Variant
 
  arr = Array("BBR", "BMTR", "VSR", "STR")      'fit sheets name
 
  For Each itm In arr
    Set sh = Sheets(itm)
    nMax = nMax + sh.Range("A" & Rows.Count).End(3).Row - 1
  Next
  ReDim b(1 To nMax, 1 To 8)
 
  For Each itm In arr
    Set sh = Sheets(itm)
    a = sh.Range("A2", sh.Range("G" & Rows.Count).End(3)).Value
    For i = 1 To UBound(a, 1)
      k = k + 1
      b(k, 1) = a(i, 1)
      b(k, 2) = a(i, 2)
      b(k, 3) = a(i, 4)
      Select Case itm
        Case "BBR": b(k, 4) = a(i, 7)
        Case "BMTR": b(k, 5) = a(i, 7)
        Case "VSR": b(k, 6) = a(i, 7)
        Case "STR": b(k, 7) = a(i, 7)
      End Select
    Next
  Next
 
  Application.ScreenUpdating = False
  With Sheets("BBR")
    .Range("AA:AG").Clear 'Contents
    .Range("AA2").Resize(k, 7).Value = b
    .Range("AA1:AG" & UBound(b) + 1).Sort .Range("AB1"), xlAscending, Header:=xlYes
    c = .Range("AA1:AG" & UBound(b) + 1).Value
    .Range("AA:AG").ClearContents
  End With
  Application.ScreenUpdating = True
 
  ListBox1.ColumnCount = 8
 
  Call FilterData
End Sub

🧙‍♂️
 
Upvote 0
I made some small changes to the code.
The filter by date will be carried out until you capture both dates.

Try this version:

VBA Code:
Dim c As Variant

Private Sub Textbox1_Change()
  Call FilterData
End Sub
Private Sub Textbox2_Change()
  Call FilterData
End Sub

Private Sub FilterData()
  Dim tb1 As Date, tb2 As Date
  Dim i As Long, j As Long, k As Long, y As Long, nRow As Long
  Dim b As Variant, d As Variant, ky As Variant
  Dim dic As Object
  Dim t1 As Double, t2 As Double, t3 As Double, t4 As Double
  Const frm As String = "#,##0.00;-#,##0.00;-"
 
  'Date validation
  ListBox1.Clear
  If Len(TextBox1.Value) <> 10 And TextBox1.Value <> "" Then Exit Sub
  If Len(TextBox2.Value) <> 10 And TextBox2.Value <> "" Then Exit Sub
  If Not IsDate(TextBox1.Value) And TextBox1.Value <> "" Then Exit Sub
  If Not IsDate(TextBox2.Value) And TextBox2.Value <> "" Then Exit Sub
  If TextBox1.Value <> "" And TextBox2.Value = "" Then Exit Sub
  If TextBox1.Value = "" And TextBox2.Value <> "" Then Exit Sub
  If TextBox1.Value <> "" And TextBox2.Value <> "" Then
    If CDate(TextBox2.Value) < CDate(TextBox1.Value) Then
      MsgBox "The end date is less than the start date"
      Exit Sub
    End If
  End If
  
  'Prepare listbox
  Set dic = CreateObject("Scripting.Dictionary")
  ReDim b(1 To UBound(c, 1), 1 To UBound(c, 2))
  ReDim d(1 To UBound(c, 1), 1 To 8)
  d(1, 1) = "ITEM"
  d(1, 2) = "BATCH"
  d(1, 3) = "ID"
  d(1, 4) = "BBR"
  d(1, 5) = "BMTR"
  d(1, 6) = "BMTR"
  d(1, 7) = "VSR"
  d(1, 8) = "TOTAL"
  y = 1
 
  'Data processing
  For i = 2 To UBound(c)
    If TextBox1.Value = "" Then tb1 = CDate(c(i, 1)) Else tb1 = CDate(TextBox1.Value)
    If TextBox2.Value = "" Then tb2 = CDate(c(i, 1)) Else tb2 = CDate(TextBox2.Value)
    If CDate(c(i, 1)) >= tb1 And CDate(c(i, 1)) <= tb2 Then
      ky = c(i, 3)
      If Not dic.exists(ky) Then
        y = y + 1
        dic(ky) = y
      End If
      nRow = dic(ky)
      d(nRow, 1) = nRow - 1
      d(nRow, 2) = c(i, 2)
      d(nRow, 3) = c(i, 3)
      d(nRow, 4) = d(nRow, 4) + c(i, 4)
      d(nRow, 5) = d(nRow, 5) + c(i, 5)
      d(nRow, 6) = d(nRow, 6) + c(i, 6)
      d(nRow, 7) = d(nRow, 7) + c(i, 7)
      d(nRow, 8) = d(nRow, 4) - d(nRow, 5) + d(nRow, 6) - d(nRow, 7)
      t1 = t1 + c(i, 4)
      t2 = t2 + c(i, 5)
      t3 = t3 + c(i, 6)
      t4 = t4 + c(i, 7)
    End If
  Next
  For i = 2 To dic.Count + 1
    d(i, 4) = Format(d(i, 4), frm)
    d(i, 5) = Format(d(i, 5), frm)
    d(i, 6) = Format(d(i, 6), frm)
    d(i, 7) = Format(d(i, 7), frm)
    d(i, 8) = Format(d(i, 8), frm)
  Next
  
  d(dic.Count + 2, 1) = "TOTAL"
  d(dic.Count + 2, 8) = Format(t1 - t2 + t3 - t4, frm)
 
  'Output
  ListBox1.List = d
End Sub

Private Sub UserForm_Activate()
  Dim i As Long, nMax As Long, k As Long
  Dim sh As Worksheet
  Dim arr As Variant, itm As Variant
  Dim a As Variant, b As Variant
 
  arr = Array("BBR", "BMTR", "VSR", "STR")      'fit sheets name
 
  For Each itm In arr
    Set sh = Sheets(itm)
    nMax = nMax + sh.Range("A" & Rows.Count).End(3).Row - 1
  Next
  ReDim b(1 To nMax, 1 To 8)
 
  For Each itm In arr
    Set sh = Sheets(itm)
    a = sh.Range("A2", sh.Range("G" & Rows.Count).End(3)).Value
    For i = 1 To UBound(a, 1)
      k = k + 1
      b(k, 1) = a(i, 1)
      b(k, 2) = a(i, 2)
      b(k, 3) = a(i, 4)
      Select Case itm
        Case "BBR":   b(k, 4) = a(i, 7)
        Case "BMTR":  b(k, 5) = a(i, 7)
        Case "VSR":   b(k, 6) = a(i, 7)
        Case "STR":   b(k, 7) = a(i, 7)
      End Select
    Next
  Next
 
  Application.ScreenUpdating = False
  With Sheets("BBR")
    .Range("AA:AG").Clear
    .Range("AA2").Resize(k, 7).Value = b
    .Range("AA1:AG" & UBound(b) + 1).Sort .Range("AB1"), xlAscending, Header:=xlYes
    c = .Range("AA1:AG" & UBound(b) + 1).Value
    .Range("AA:AG").Clear
  End With
  Application.ScreenUpdating = True
 
  ListBox1.ColumnCount = 8
  Call FilterData
End Sub

😇
 
Upvote 0
Solution
thanks for writing the code for me:)
it's not enough fast ,will take about 5.6 sec for 13000 rows for each sheet , but it's still acceptable.
just I would fix space before last column ,it's really wide , I 'm not sure what's the problem despite of use this
VBA Code:
With ListBox1
  .ColumnWidths = "70,80;100;100;70;70;70;70"
  End With
in the end of code , but the problem still continues . I'm not sure what my bad !:rolleyes:
any idea to fix it please?
 
Upvote 0
it's not enough fast ,will take about 5.6 sec for 13000 rows for each sheet , but it's still acceptable.
I guess it's only at the beginning. Next, filters by date should be faster.

In the Activate event

Change this:
VBA Code:
ListBox1.ColumnCount = 8

For this:
VBA Code:
  With ListBox1
    .ColumnCount = 8
    .ColumnWidths = "50;80;100;100;70;70;70;70"
  End With

😇
 
Upvote 0

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top