transposing accounts on userform for each sheet contains customer

Alaa mg · Feb 9, 2025

Hello,
I have data in multiple sheets before OUT sheet where run the form and I will add new sheets before OUT sheet.

AL.xlsm

A

B

C

D

E

F

1

DATE

NAME

DETAILES

DEBIT

CREDIT

BALANCE

2

31/10/2024

ALAA

OPENING BALANCE

30,000.00

3

03/11/2024

ALAA

BUYING RETURNS IBN3446

1,000.00

31,000.00

4

04/11/2024

ALAA

PAID VDF10000

300.00

30,700.00

5

05/11/2024

ALAA

SALES INVBN200

2,000.00

32,700.00

6

06/11/2024

ALAA

BUYING IBN3444

10,000.00

22,700.00

7

07/11/2024

ALAA

BUYING RETURNS IBN3445

3,000.00

25,700.00

8

08/11/2024

ALAA

SALES INVBN201

2,000.00

27,700.00

9

09/11/2024

ALAA

SALES RETURNS INVBN202

1,200.00

26,500.00

10

10/11/2024

ALAA

RECEIVED VBF5666

1,100.00

27,600.00

11

11/11/2024

ALAA

RECEIVED VBF5667

2,000.00

29,600.00

12

TOTAL

41,100.00

11,500.00

29,600.00

SH

Cell Formulas
Range	Formula
F3:F11	F3	=F2+D3-E3
D12:E12	D12	=SUM(D2:D11)
F12	F12	=D12-E12

AL.xlsm

A

B

C

D

E

F

1

DATE

NAME

DETAILES

DEBIT

CREDIT

BALANCE

2

31/10/2024

ALIAS

OPENING BALANCE

10,000.00

-10,000.00

3

02/11/2024

ALIAS

SALES INVBN203

2,000.00

-8,000.00

4

03/11/2024

ALIAS

BUYING RETURNS IBN3449

1,200.00

-6,800.00

5

04/11/2024

ALIAS

PAID VDF10001

200.00

-7,000.00

6

05/11/2024

ALIAS

PAID VDF10002

200.00

-7,200.00

7

06/11/2024

ALIAS

PAID VDF10003

200.00

-7,400.00

8

07/11/2024

ALIAS

SALES INVBN204

2,000.00

-5,400.00

9

08/11/2024

ALIAS

BUYING IBN3447

1,000.00

-6,400.00

10

09/11/2024

ALIAS

BUYING RETURNS IBN3448

1,500.00

-4,900.00

11

10/11/2024

ALIAS

RECEIVED VBF5669

2,000.00

-2,900.00

12

TOTAL

8,700.00

11,600.00

-2,900.00

ASD

Cell Formulas
Range	Formula
F3:F11	F3	=F2+D3-E3
D12:E12	D12	=SUM(D2:D11)
F12	F12	=D12-E12

the result on form

rest of picture

so should merge duplicates items (sales, sales returns, buying , buying returns, paid, received) in column C for each name in column B for each sheet contains name alone except OPENING BALANCE , in second column in listbox will brings balance from TOTAL row from BALANCE column (F), rest of columns will merge duplicates items
TOTAL row will sum each column . NET row will be subtract amounts in TOTAL row from each column
NET row will be :
SALES=8000-1200=6800 (subtract TOTAL sales from TOTAL sales returns)
BUYING =11000-6700=4300(subtract TOTAL buying from TOTAL buying returns)
RECEIVED=5100-900=4200(subtract TOTAL RECEIVED from TOTAL paid )
there is no more items , just as in sheets .
and without forgetting populate data based on dates in textbox1,2.
thanks

DanteAmor · Feb 9, 2025

Considerations:

1. Works for sheets from the first sheet and until before the "OUT" sheet.

2. Only one name per sheet. If there are more names on the same sheet then the macro must be adjusted.

3. At the beginning of the code, it may be slow, since it will be reading and arranging the information from all the sheets, but when executing the date filters, it will be faster.

Try:

VBA Code:

Option Explicit 'At the beginning of all the code

Dim b As Variant
Dim arr As Variant
Dim num As Long

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 c As Variant, ky As Variant, d As Variant
  Dim dic As Object
  Dim vle As Double, net As String, bal As Double, totbal As Double
  Const frm As String = "#,##0.00;-#,##0.00;-"
 
  Set dic = CreateObject("Scripting.Dictionary")
  
  'Date validation
  If Len(TextBox1.Value) <> 10 And TextBox1.Value <> "" Then Exit Sub
  If Len(TextBox2.Value) <> 10 And TextBox2.Value <> "" Then Exit Sub
  
  'Prepare listbox
  ListBox1.Clear
  ReDim c(1 To num + 3, 1 To 9)     '+1 HEAD, +1 TOTAL, +1 NET
  ReDim d(1 To 1, 1 To 9)           'TOTAL and NET
  k = 1
  For j = 1 To UBound(arr)          'Add headers
    c(k, j) = arr(j)
  Next
 
  'Data processing
  y = 1
  For i = 1 To UBound(b)
    If TextBox1.Value = "" Then tb1 = CDate(b(i, 10)) Else tb1 = CDate(TextBox1.Value)
    If TextBox2.Value = "" Then tb2 = CDate(b(i, 10)) Else tb2 = CDate(TextBox2.Value)
    If CDate(b(i, 10)) >= tb1 And CDate(b(i, 10)) <= tb2 Then
      ky = b(i, 1)
      If Not dic.exists(ky) Then
        y = y + 1
        dic(ky) = y
        bal = 0
      End If
      nRow = dic(ky)
      For j = 1 To UBound(b, 2) - 1
        Select Case j
          Case 1
            c(nRow, j) = b(i, j)
          Case 2
            '3+4+7+9 - 5-6-8
            If c(nRow, j) = "-" Or c(nRow, j) = "" Then bal = 0 Else bal = CDbl(c(nRow, j))
            bal = bal + b(i, 3) + b(i, 4) + b(i, 7) + b(i, 9) - b(i, 5) - b(i, 6) - b(i, 8)
            totbal = totbal + b(i, 3) + b(i, 4) + b(i, 7) + b(i, 9) - b(i, 5) - b(i, 6) - b(i, 8)
            c(nRow, j) = Format(bal, frm)
            d(1, j) = totbal                          'accumulate total
          Case Else
            If c(nRow, j) = "-" Or c(nRow, j) = "" Then vle = 0 Else vle = CDbl(c(nRow, j))
            c(nRow, j) = Format(vle + b(i, j), frm)   'accommodate dbt or cdt in its column
            d(1, j) = d(1, j) + b(i, j)               'accumulate total
        End Select
      Next
    End If
  Next
  
  'Total & Net
  y = dic.Count
  c(y + 2, 1) = "TOTAL"
  c(y + 3, 1) = "NET"
  For j = 2 To UBound(c, 2)
    c(y + 2, j) = Format(d(1, j), frm)
    Select Case j
      Case 2, 3, 5, 7, 8: net = 0
      Case 4:             net = d(1, j) - d(1, 8)
      Case 6:             net = d(1, j) - d(1, 7)
      Case 9:             net = d(1, j) - d(1, 5)
    End Select
    c(y + 3, j) = Format(net, frm)
  Next
  'Output
  ListBox1.List = c
End Sub

Private Sub UserForm_Activate()
  Dim i As Long, j As Long, nMax As Long, k As Long, n As Long
  Dim sh As Worksheet
  Dim a As Variant
  Dim dic As Object
  Dim det As String
  
  Set dic = CreateObject("Scripting.Dictionary")
 
  arr = Array("", "NAME", "BALANCE", "OPENING BALANCE", "SALES", "PAID", _
              "BUYING", "BUYING RETURNS", "SALES RETURNS", "RECEIVED")
  
  For j = 1 To UBound(arr)
    dic(arr(j)) = j
  Next
 
  For n = 1 To Sheets.Count
    Set sh = Sheets(n)
    If sh.Name = "OUT" Then Exit For
    num = num + 1
    nMax = nMax + (sh.Range("A" & Rows.Count).End(3).Row - 2)
  Next
  ReDim b(1 To nMax, 1 To 10)    'to listbox1
 
  For n = 1 To num  'Sheets.Count
    Set sh = Sheets(n)
    a = sh.Range("A2:F" & sh.Range("B" & Rows.Count).End(3).Row).Value
    For i = 1 To UBound(a)
      det = Split(a(i, 3), " ")(0) & " " & Split(a(i, 3), " ")(1)
      If Not dic.exists(det) Then det = Split(a(i, 3), " ")(0)
      If dic.exists(det) Then
        k = k + 1
        j = dic(det)
        b(k, 10) = a(i, 1)              'date
        b(k, 1) = a(i, 2)               'name
        b(k, j) = IIf(det = "OPENING BALANCE", a(i, 4) - a(i, 5), a(i, 4) + a(i, 5))
      End If
    Next
  Next

  ListBox1.ColumnCount = 9
  Call FilterData
End Sub

Alaa mg · Feb 9, 2025

Thanks.

1. Works for sheets from the first sheet and until before the "OUT" sheet.
2. Only one name per sheet. If there are more names on the same sheet then the macro must be adjusted.

I completely agree with you.

I tested when run the form is ok but when write date in textbox2 will show invalid null error in this line

VBA Code:

  Case 4:             net = d(1, j) - d(1, 8)

so I write in textbox1=01/01/2024 textbox2=11/01/2024 I know this is not available but I expect when there is no data then shouldn't show data in listbox when write dates are not existed.

3. At the beginning of the code, it may be slow, since it will be reading and arranging the information from all the sheets, but when executing the date filters, it will be faster.

right but just with two sheets , if use 30 sheets and each sheet contains 4000 row at least will be more slow !

DanteAmor · Feb 9, 2025

Alaa mg said:
right but just with two sheets , if use 30 sheets and each sheet contains 4000 row at least will be more slow

1. Consider that you must be aware of the number of records.

2. It's not just reading the data and putting it in the listbox, you have many rules and calculations.

3. You will have to sacrifice the beginning of the charge.
4. Thanks to the logic I am using, filters by dates will be faster.

Test with all your sheets and all the records and comment on how long it takes at the beginning and how long it takes with each date filter.

Alaa mg said:
but I expect when there is no data then shouldn't show data in listbox

You didn't specify what dates you are going to put, I expect that you put correct dates...
But I added more validations to the dates.

Try:

VBA Code:

Option Explicit 'At the beginning of all the code

Dim b As Variant
Dim arr As Variant
Dim num As Long

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 c As Variant, ky As Variant, d As Variant
  Dim dic As Object
  Dim vle As Double, net As String, bal As Double, totbal As Double
  Const frm As String = "#,##0.00;-#,##0.00;-"
 
  Set dic = CreateObject("Scripting.Dictionary")
  ListBox1.Clear
  
  '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
  ReDim c(1 To num + 3, 1 To 9)     'num sheets, +1 HEAD, +1 TOTAL, +1 NET
  ReDim d(1 To 1, 1 To 9)           'TOTAL and NET
  k = 1
  For j = 1 To UBound(arr)          'Add headers
    c(k, j) = arr(j)
  Next
 
  'Data processing
  y = 1
  For i = 1 To UBound(b)
    If TextBox1.Value = "" Then tb1 = CDate(b(i, 10)) Else tb1 = CDate(TextBox1.Value)
    If TextBox2.Value = "" Then tb2 = CDate(b(i, 10)) Else tb2 = CDate(TextBox2.Value)
    If CDate(b(i, 10)) >= tb1 And CDate(b(i, 10)) <= tb2 Then
      ky = b(i, 1)
      If Not dic.exists(ky) Then
        y = y + 1
        dic(ky) = y
        bal = 0
      End If
      nRow = dic(ky)
      For j = 1 To UBound(b, 2) - 1
        Select Case j
          Case 1
            c(nRow, j) = b(i, j)
          Case 2
            '3+4+7+9 - 5-6-8
            If c(nRow, j) = "-" Or c(nRow, j) = "" Then bal = 0 Else bal = CDbl(c(nRow, j))
            bal = bal + b(i, 3) + b(i, 4) + b(i, 7) + b(i, 9) - b(i, 5) - b(i, 6) - b(i, 8)
            totbal = totbal + b(i, 3) + b(i, 4) + b(i, 7) + b(i, 9) - b(i, 5) - b(i, 6) - b(i, 8)
            c(nRow, j) = Format(bal, frm)
            d(1, j) = totbal                          'accumulate total
          Case Else
            If c(nRow, j) = "-" Or c(nRow, j) = "" Then vle = 0 Else vle = CDbl(c(nRow, j))
            c(nRow, j) = Format(vle + b(i, j), frm)   'accommodate dbt or cdt in its column
            d(1, j) = d(1, j) + b(i, j)               'accumulate total
        End Select
      Next
    End If
  Next
  
  'Total & Net
  y = dic.Count
  If y = 0 Then
    MsgBox "There are no values between those dates"
    Exit Sub
  End If
  c(y + 2, 1) = "TOTAL"
  c(y + 3, 1) = "NET"
  For j = 2 To UBound(c, 2)
    c(y + 2, j) = Format(d(1, j), frm)
    Select Case j
      Case 2, 3, 5, 7, 8: net = 0
      Case 4:             net = d(1, j) - d(1, 8)
      Case 6:             net = d(1, j) - d(1, 7)
      Case 9:             net = d(1, j) - d(1, 5)
    End Select
    c(y + 3, j) = Format(net, frm)
  Next
  'Output
  ListBox1.List = c
End Sub

Private Sub UserForm_Activate()
  Dim i As Long, j As Long, nMax As Long, k As Long, n As Long
  Dim sh As Worksheet
  Dim a As Variant
  Dim dic As Object
  Dim det As String
  
  Set dic = CreateObject("Scripting.Dictionary")
 
  arr = Array("", "NAME", "BALANCE", "OPENING BALANCE", "SALES", "PAID", _
              "BUYING", "BUYING RETURNS", "SALES RETURNS", "RECEIVED")
  
  For j = 1 To UBound(arr)
    dic(arr(j)) = j
  Next
 
  For n = 1 To Sheets.Count
    Set sh = Sheets(n)
    If sh.Name = "OUT" Then Exit For
    num = num + 1
    nMax = nMax + (sh.Range("A" & Rows.Count).End(3).Row - 2)
  Next
  ReDim b(1 To nMax, 1 To 10)    'to listbox1
 
  For n = 1 To num  'Sheets.Count
    Set sh = Sheets(n)
    a = sh.Range("A2:F" & sh.Range("B" & Rows.Count).End(3).Row).Value
    For i = 1 To UBound(a)
      det = Split(a(i, 3), " ")(0) & " " & Split(a(i, 3), " ")(1)
      If Not dic.exists(det) Then det = Split(a(i, 3), " ")(0)
      If dic.exists(det) Then
        k = k + 1
        j = dic(det)
        b(k, 10) = a(i, 1)              'date
        b(k, 1) = a(i, 2)               'name
        b(k, j) = IIf(det = "OPENING BALANCE", a(i, 4) - a(i, 5), a(i, 4) + a(i, 5))
      End If
    Next
  Next

  ListBox1.ColumnCount = 9
  Call FilterData
End Sub

DanteAmor · Feb 10, 2025

Try this macro version. I made some adjustments.
I did tests with 32 sheets and each sheet with more than 4 thousand records. And loading and filtering by date takes 4 to 5 seconds.

VBA Code:

Option Explicit 'At the beginning of all the code

Dim b As Variant
Dim arr As Variant
Dim num As Long

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 c As Variant, ky As Variant, d As Variant
  Dim dic As Object
  Dim vle As Double, net As String, bal As Double, totbal As Double
  Const frm As String = "#,##0.00;-#,##0.00;-"
 
  Set dic = CreateObject("Scripting.Dictionary")
  ListBox1.Clear
  
  '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
  ReDim c(1 To num + 3, 1 To 9)     'num sheets, +1 HEAD, +1 TOTAL, +1 NET
  ReDim d(1 To 1, 1 To 9)           'TOTAL and NET
  k = 1
  For j = 1 To UBound(arr)          'Add headers
    c(k, j) = arr(j)
  Next
 
  'Data processing
  y = 1
  For i = 1 To UBound(b)
    If TextBox1.Value = "" Then tb1 = CDate(b(i, 10)) Else tb1 = CDate(TextBox1.Value)
    If TextBox2.Value = "" Then tb2 = CDate(b(i, 10)) Else tb2 = CDate(TextBox2.Value)
    If CDate(b(i, 10)) >= tb1 And CDate(b(i, 10)) <= tb2 Then
      
      ky = b(i, 1)
      If ky <> "" Then
        If Not dic.exists(ky) Then
          y = y + 1
          dic(ky) = y
          bal = 0
        End If
        nRow = dic(ky)
        For j = 1 To UBound(b, 2) - 1
          Select Case j
            Case 1
              c(nRow, j) = b(i, j)
            Case 2
              '3+4+7+9 - 5-6-8
              If c(nRow, j) = "-" Or c(nRow, j) = "" Then bal = 0 Else bal = CDbl(c(nRow, j))
              bal = bal + b(i, 3) + b(i, 4) + b(i, 7) + b(i, 9) - b(i, 5) - b(i, 6) - b(i, 8)
              totbal = totbal + b(i, 3) + b(i, 4) + b(i, 7) + b(i, 9) - b(i, 5) - b(i, 6) - b(i, 8)
              c(nRow, j) = Format(bal, frm)
              d(1, j) = totbal                          'accumulate total
            Case Else
              If c(nRow, j) = "-" Or c(nRow, j) = "" Then vle = 0 Else vle = CDbl(c(nRow, j))
              c(nRow, j) = Format(vle + b(i, j), frm)   'accommodate dbt or cdt in its column
              d(1, j) = d(1, j) + b(i, j)               'accumulate total
          End Select
        Next
      End If
    End If
  Next
  
  'Total & Net
  y = dic.Count
  If y = 0 Then
    MsgBox "There are no values between those dates"
    Exit Sub
  End If
  c(y + 2, 1) = "TOTAL"
  c(y + 3, 1) = "NET"
  For j = 2 To UBound(c, 2)
    c(y + 2, j) = Format(d(1, j), frm)
    Select Case j
      Case 2, 3, 5, 7, 8: net = 0
      Case 4:             net = d(1, j) - d(1, 8)
      Case 6:             net = d(1, j) - d(1, 7)
      Case 9:             net = d(1, j) - d(1, 5)
    End Select
    c(y + 3, j) = Format(net, frm)
  Next
  'Output
  ListBox1.List = c
End Sub

Private Sub UserForm_Activate()
  Dim i As Long, j As Long, nMax As Long, k As Long, n As Long
  Dim sh As Worksheet
  Dim a As Variant
  Dim dic As Object
  Dim det As String
  
  Set dic = CreateObject("Scripting.Dictionary")
 
  arr = Array("", "NAME", "BALANCE", "OPENING BALANCE", "SALES", "PAID", _
              "BUYING", "BUYING RETURNS", "SALES RETURNS", "RECEIVED")
  
  For j = 1 To UBound(arr)
    dic(arr(j)) = j
  Next
 
  For n = 1 To Sheets.Count
    Set sh = Sheets(n)
    If sh.Name = "OUT" Then Exit For
    num = num + 1
    nMax = nMax + (sh.Range("A" & Rows.Count).End(3).Row - 1)
  Next
  ReDim b(1 To nMax, 1 To 10)    'to listbox1
 
  For n = 1 To num  'Sheets.Count
    Set sh = Sheets(n)
    a = sh.Range("A2:F" & sh.Range("B" & Rows.Count).End(3).Row).Value
    For i = 1 To UBound(a)
      det = Split(a(i, 3), " ")(0) & " " & Split(a(i, 3), " ")(1)
      If Not dic.exists(det) Then det = Split(a(i, 3), " ")(0)
      If dic.exists(det) Then
        k = k + 1
        j = dic(det)
        b(k, 10) = a(i, 1)              'date
        b(k, 1) = a(i, 2)               'name
        b(k, j) = IIf(det = "OPENING BALANCE", a(i, 4) - a(i, 5), a(i, 4) + a(i, 5))
      End If
    Next
  Next

  ListBox1.ColumnCount = 9
  Call FilterData
End Sub

Alaa mg · Feb 10, 2025

really better !

many thanks for improving the code.

transposing accounts on userform for each sheet contains customer

Alaa mg

Active Member

DanteAmor

Well-known Member

Alaa mg

Active Member

DanteAmor

Well-known Member

DanteAmor

Well-known Member

Alaa mg

Active Member

Similar threads

Forum statistics

Share this page

transposing accounts on userform for each sheet contains customer

Alaa mg

Active Member

DanteAmor

Well-known Member

Alaa mg

Active Member

DanteAmor

Well-known Member

DanteAmor

Well-known Member

Alaa mg

Active Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock