combine data in listbox on userform based on another listbox

[Maklil]

Hello
I would show data across sheets by arrange for each name and each sheet and should show data in listbox start from first sheet and sort from first date to last date .

mk1.xlsm
	A	B	C	D	E	F	G	H
1	DATE	INV NO	NAME	ID	CASE	QTY	UNIT PRICE	BALANCE
2	20/08/2023	MMUY7000	MVS	OOIL AS-100	PAID	20.00	160.00	3,200.00
3	20/08/2023	MMUY7000	MVS	OOIL AS-101	PAID	20.00	180.00	3,600.00
4	TOTAL							6,800.00
5	20/08/2023	MMUY7001	MVS	OOIL AS-102	PAID	40.00	155.00	6,200.00
6	20/08/2023	MMUY7001	MVS	OOIL AS-103	PAID	20.00	190.00	3,800.00
7	TOTAL							10,000.00
8	21/08/2023	MMUY7002	MVS	OOIL AS-103	NOT PAID	25.00	190.00	4,750.00
9	TOTAL							4,750.00
10	21/08/2023		MSS	OOIL AS-103	NOT PAID	25.00	180.00	4,500.00
11	21/08/2023		MSS	OOIL AS-104	NOT PAID	40.00	177.00	7,080.00
12	TOTAL			OOIL AS-105				11,580.00
13	21/08/2023	MMUY7002	MVS	OOIL AS-103	NOT PAID	100.00	196.00	19,600.00
14	TOTAL							19,600.00
15
MK

Cell Formulas
Range	Formula
H13,H10:H11,H8,H5:H6,H2:H3	H2	=F2*G2
H4,H12,H7	H4	=SUM(H2:H3)
H9,H14	H9	=SUM(H8)

mk1.xlsm
	A	B	C	D	E	F	G	H
1	DATE	INV NO	NAME	ID	CASE	QTY	UNIT PRICE	BALANCE
2	20/08/2023	ST NO 1000	MVS	GNOO HH 1200	RECEIVED	10.00	150.00	1,500.00
3	20/08/2023	ST NO 1000	MVS	AS100-12	RECEIVED	10.00	130.00	1,300.00
4	TOTAL							2,800.00
5	21/08/2023	ST NO 1001	MTT	MGFH GA-103	NOT REICEVED	15.00	130.00	1,950.00
6	TOTAL							1,950.00
7	21/08/2023	ST NO 1002	MLL	SSFOO 1000 MN1	NOT REICEVED	2.00	140.00	280.00
8	21/08/2023	ST NO 1002	MLL	SSFOO 1000 MN2	NOT REICEVED	12.00	145.00	1,740.00
9	21/08/2023	ST NO 1002	MLL	SSFOO 1000 MN3	NOT REICEVED	10.00	145.00	1,450.00
10	TOTAL							3,470.00
11	24/08/2023	VT NO 1003	MKK	OOIL AS-100	RECEIVED	10.00	145.00	1,450.00
12	24/08/2023	VT NO 1003	MKK	OOIL AS-101	RECEIVED	25.00	150.00	3,750.00
13	24/08/2023	VT NO 1003	MKK	OOIL AS-102	RECEIVED	40.00	155.00	6,200.00
14	24/08/2023	VT NO 1003	MKK	OOIL AS-103	RECEIVED	55.00	160.00	8,800.00
15	24/08/2023	VT NO 1003	MKK	OOIL AS-104	RECEIVED	70.00	165.00	11,550.00
16	24/08/2023	VT NO 1003	MKK	OOIL AS-105	RECEIVED	85.00	170.00	14,450.00
17	24/08/2023	VT NO 1003	MKK	OOIL AS-106	RECEIVED	100.00	175.00	17,500.00
18	24/08/2023	VT NO 1003	MKK	OOIL AS-107	RECEIVED	115.00	180.00	20,700.00
19	TOTAL							84,400.00
20	24/08/2023	ST NO 1002	MLL	SSFOO 1000 MN11	NOT REICEVED	12.00	160.00	1,920.00
21	24/08/2023	ST NO 1002	MLL	SSFOO 1000 MN21	NOT REICEVED	12.00	170.00	2,040.00
22	TOTAL							3,960.00
MT

Cell Formulas
Range	Formula
H11:H18,H5,H2:H3	H2	=F2*G2
H4,H22	H4	=SUM(H2:H3)
H6	H6	=SUM(H5:H5)
H20:H21,H7:H9	H7	=G7*F7
H10	H10	=SUM(H7:H9)
H19	H19	=SUM(H11:H18)

mk1.xlsm
	A	B	C	D	E	F	G	H
1	DATE	INV NO	NAME	ID	CASE	QTY	UNIT PRICE	BALANCE
2	20/08/2023	MSSUY4000	MVS	OOIL AS-100	RECEIVED	1.00	160.00	160.00
3	20/08/2023	MSSUY4000	MVS	OOIL AS-101	RECEIVED	1.00	180.00	180.00
4	TOTAL							340.00
5	20/08/2023	MSSUY4001	MVS	OOIL AS-102	NOT REICEVED	1.00	155.00	155.00
6	20/08/2023	MSSUY4001	MVS	OOIL AS-103	NOT REICEVED	1.00	190.00	190.00
7	TOTAL							345.00
8	21/08/2023	MSSUY4002	MVS	OOIL AS-102	RECEIVED	2.00	155.00	310.00
9	TOTAL							655.00
10	21/08/2023	MSSUY4003	MSS	OOIL AS-100	NOT REICEVED	1.00	160.00	160.00
11	21/08/2023	MSSUY4003	MSS	OOIL AS-101	NOT REICEVED	1.00	180.00	180.00
12	21/08/2023	MSSUY4003	MSS	OOIL AS-102	NOT REICEVED	1.00	155.00	155.00
13	TOTAL							495.00
MS

Cell Formulas
Range	Formula
H10:H12,H8,H5:H6,H2:H3	H2	=F2*G2
H4,H9,H7	H4	=SUM(H2:H3)
H13	H13	=SUM(H10:H12)

mk1.xlsm
	A	B	C	D	E	F	G	H
1	DATE	INV NO	NAME	ID	CASE	QTY	UNIT PRICE	BALANCE
2	24/08/2023	VT NO 1003	MKK	OOIL AS-100	NOT PAID	1.00	145.00	145.00
3	24/08/2023	VT NO 1003	MKK	OOIL AS-101	NOT PAID	1.00	150.00	150.00
4	24/08/2023	VT NO 1003	MKK	OOIL AS-102	NOT PAID	2.00	155.00	310.00
5	24/08/2023	VT NO 1003	MKK	OOIL AS-103	NOT PAID	4.00	160.00	640.00
6	TOTAL							1,245.00
7	25/08/2023	VT NO 1004	MKK	OOIL AS-101	PAID	1.00	150.00	150.00
8	25/08/2023	VT NO 1004	MKK	OOIL AS-102	PAID	2.00	155.00	310.00
9	TOTAL							460.00
10	25/08/2023	VT NO 1005	MLL	OOIL AS-103	PAID	4.00	160.00	640.00
11	TOTAL							640.00
12	25/08/2023	VT NO 1006	MLL	OOIL AS-102	PAID	2.00	155.00	310.00
13	25/08/2023	VT NO 1006	MLL	OOIL AS-103	PAID	4.00	160.00	640.00
14	TOTAL							950.00
15	25/08/2023	VT NO 1007	MVS	OOIL AS-101	PAID	3.00	150.00	450.00
16	TOTAL							450.00
ATS

Cell Formulas
Range	Formula
H15,H12:H13,H10,H7:H8,H2:H5	H2	=F2*G2
H6	H6	=SUM(H2:H5)
H9,H14	H9	=SUM(H7:H8)
H11,H16	H11	=SUM(H10)

so in first column will show date dd/mm/yyyy
second column brings names
third column populate sheets names for each name where is location in sheet.
fourth second shows CASE column
fifth column will brings amount from TOTAL row for each name from column H .
after show data in listbox1 then will merge data in listbox2 based on sheet name and case columns for 3,4 together.
so the form before

after

and if it's possible also when write dates in TB1,TB2 so will sort in listbox1 based dates and merged in listbox2 .
if TB1,TB2 are empty then will show all of data across sheets.
the data could be 10000 rows for each sheet.
thanks.

 

[DanteAmor]

Try the following code in your userform.
It may be a little slow at first, as it will load all the data from all the sheets into an array, and the data will be placed in columns AA to AE in sheet "MK" for sorting, after that the columns will be cleared.

Filters with textbox1 and textbox2 should be faster.

Set the sheets and their names in this line of the macro:

arr = Array("MK", "MT", "MS", "ATS")​

Option Explicit 'At the beginning of all the code

Dim c As Variant
Const frm As String = "#,##0.00"

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
  
  If Len(TextBox1.Value) <> 10 And TextBox1 <> "" Then Exit Sub
  If Len(TextBox2.Value) <> 10 And TextBox2 <> "" Then Exit Sub
    
  Set dic = CreateObject("Scripting.Dictionary")
  ListBox1.Clear
  ListBox2.Clear
  ReDim b(1 To UBound(c, 1), 1 To UBound(c, 2))
  ReDim d(1 To UBound(c, 1), 1 To 4)
  k = 1
  b(k, 1) = "DATE"
  b(k, 2) = "NAME"
  b(k, 3) = "SHEETS NAMES"
  b(k, 4) = "CASE"
  b(k, 5) = "BALANCE"
  
  y = 1
  d(y, 1) = "ITEM"
  d(y, 2) = "SHEETS NAMES"
  d(y, 3) = "CASE"
  d(y, 4) = "BALANCE"
  
  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
      k = k + 1
      For j = 1 To UBound(c, 2)
        b(k, j) = c(i, j)
      Next
      
      ky = b(k, 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) = b(k, 3)
      d(nRow, 3) = b(k, 4)
      If b(k, 5) <> "" Then
        d(nRow, 4) = Format(CDbl(d(nRow, 4)) + CDbl(b(k, 5)), frm) 'a(i, 8)
      End If

    End If
  Next
  
  If k = 0 Then
    MsgBox "doesn't show data"
  Else
    ListBox1.List = b
    ListBox2.List = d
  End If
End Sub

Private Sub UserForm_Activate()
  Dim i As Long, nMax As Long, k As Long, lr As Long
  Dim y As Long, nRow As Long
  Dim sh As Worksheet
  Dim arr As Variant, itm As Variant, ky As Variant
  Dim a As Variant, b As Variant, d As Variant
  Dim dic As Object
  
  arr = Array("MK", "MT", "MS", "ATS")
  Set dic = CreateObject("Scripting.Dictionary")
  
  For Each itm In arr
    Set sh = Sheets(itm)
    nMax = nMax + WorksheetFunction.CountIf(sh.Range("A:A"), "TOTAL")
  Next
  ReDim b(1 To nMax, 1 To 5)    'to listbox1
  ReDim d(1 To nMax, 1 To 4)    'to listbox2
  
  y = 1
  d(y, 1) = "ITEM"
  d(y, 2) = "SHEETS NAMES"
  d(y, 3) = "CASE"
  d(y, 4) = "BALANCE"

  For Each itm In arr
    Set sh = Sheets(itm)
    a = sh.Range("A2", sh.Range("H" & Rows.Count).End(3)).Value
    For i = 1 To UBound(a)
      If a(i, 1) = "TOTAL" Then
        k = k + 1
        b(k, 1) = Format(a(i - 1, 1), "dd/mm/yyyy")
        b(k, 2) = a(i - 1, 3)
        b(k, 3) = sh.Name
        b(k, 4) = a(i - 1, 5)
        b(k, 5) = Format(a(i, 8), frm)
        
        ky = b(k, 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) = b(k, 3)
        d(nRow, 3) = b(k, 4)
        If b(k, 5) <> "" Then
          d(nRow, 4) = Format(CDbl(d(nRow, 4)) + CDbl(b(k, 5)), frm) 'a(i, 8)
        End If
      End If
    Next
  Next
  
  Application.ScreenUpdating = False
  With Sheets("MK")
    .Range("AA:AE").ClearContents
    .Range("AA:AE").NumberFormat = "@"
    .Range("AA1").Resize(1, 5).Value = Array("DATE", "NAME", "SHEETS NAMES", "CASE", "BALANCE")
    .Range("AA2").Resize(k, 5).Value = b
    lr = .Range("AA" & Rows.Count).End(3).Row
    .Range("AA1:AE" & lr).Sort .Range("AA1"), xlAscending, .Range("AB1"), , xlAscending, Header:=xlYes
    c = .Range("AA1:AE" & lr).Value
    .Range("AA:AE").ClearContents
  End With
  Application.ScreenUpdating = True
  
  With ListBox1
    .ColumnCount = 5
    .List = c
  End With
  With ListBox2
    .ColumnCount = 4
    .List = d
  End With
End Sub

 

[DanteAmor]

Try the following code with improvements:

Option Explicit 'At the beginning of all the 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
 
  'Date validation
  If Len(TextBox1.Value) <> 10 And TextBox1 <> "" Then Exit Sub
  If Len(TextBox2.Value) <> 10 And TextBox2 <> "" Then Exit Sub
  
  'Prepare listbox
  Set dic = CreateObject("Scripting.Dictionary")
  ListBox1.Clear
  ListBox2.Clear
  ReDim b(1 To UBound(c, 1), 1 To UBound(c, 2))
  ReDim d(1 To UBound(c, 1), 1 To 4)
  k = 1
  b(k, 1) = "DATE"
  b(k, 2) = "NAME"
  b(k, 3) = "SHEETS NAMES"
  b(k, 4) = "CASE"
  b(k, 5) = "BALANCE"
 
  y = 1
  d(y, 1) = "ITEM"
  d(y, 2) = "SHEETS NAMES"
  d(y, 3) = "CASE"
  d(y, 4) = "BALANCE"
 
  '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
      k = k + 1
      For j = 1 To UBound(c, 2)
        b(k, j) = c(i, j)
      Next
     
      ky = b(k, 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) = b(k, 3)
      d(nRow, 3) = b(k, 4)
      d(nRow, 4) = Format(CDbl(d(nRow, 4)) + CDbl(b(k, 5)), "#,##0.00")

    End If
  Next
 
  'Output
  ListBox1.List = b
  ListBox2.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("MK", "MT", "MS", "ATS")      'fit sheets name
 
  For Each itm In arr
    Set sh = Sheets(itm)
    nMax = nMax + WorksheetFunction.CountIf(sh.Range("A:A"), "TOTAL")
  Next
  ReDim b(1 To nMax, 1 To 5)    'to listbox1
  ReDim d(1 To nMax, 1 To 4)    'to listbox2
 
  For Each itm In arr
    Set sh = Sheets(itm)
    a = sh.Range("A2", sh.Range("H" & Rows.Count).End(3)).Value
    For i = 1 To UBound(a)
      If a(i, 1) = "TOTAL" Then
        k = k + 1
        b(k, 1) = Format(a(i - 1, 1), "dd/mm/yyyy")
        b(k, 2) = a(i - 1, 3)
        b(k, 3) = sh.Name
        b(k, 4) = a(i - 1, 5)
        b(k, 5) = Format(a(i, 8), "#,##0.00")
      End If
    Next
  Next
 
  Application.ScreenUpdating = False
  With Sheets("MK")
    .Range("AA:AE").ClearContents
    .Range("AA:AE").NumberFormat = "@"
    .Range("AA2").Resize(k, 5).Value = b
    .Range("AA1:AE" & UBound(b) + 1).Sort .Range("AA1"), xlAscending, .Range("AB1"), , xlAscending, Header:=xlYes
    c = .Range("AA1:AE" & UBound(b) + 1).Value
    .Range("AA:AE").ClearContents
  End With
  Application.ScreenUpdating = True
 
  ListBox1.ColumnCount = 5
  ListBox2.ColumnCount = 4
 
  Call FilterData
End Sub

 

[Maklil]

it's perfect !

It may be a little slow at first

I noticed that but it's really acceptable.
many thanks.