transposing accounts on userform for each sheet contains customer

Alaa mg

Active Member
Joined
May 29, 2021
Messages
381
Office Version
  1. 2019
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
ABCDEF
1DATENAMEDETAILESDEBITCREDITBALANCE
231/10/2024ALAAOPENING BALANCE30,000.0030,000.00
303/11/2024ALAABUYING RETURNS IBN34461,000.0031,000.00
404/11/2024ALAAPAID VDF10000300.0030,700.00
505/11/2024ALAASALES INVBN2002,000.0032,700.00
606/11/2024ALAABUYING IBN344410,000.0022,700.00
707/11/2024ALAABUYING RETURNS IBN34453,000.0025,700.00
808/11/2024ALAASALES INVBN2012,000.0027,700.00
909/11/2024ALAASALES RETURNS INVBN2021,200.0026,500.00
1010/11/2024ALAARECEIVED VBF56661,100.0027,600.00
1111/11/2024ALAARECEIVED VBF56672,000.0029,600.00
12TOTAL41,100.0011,500.0029,600.00
SH
Cell Formulas
RangeFormula
F3:F11F3=F2+D3-E3
D12:E12D12=SUM(D2:D11)
F12F12=D12-E12




AL.xlsm
ABCDEF
1DATENAMEDETAILESDEBITCREDITBALANCE
231/10/2024ALIASOPENING BALANCE10,000.00-10,000.00
302/11/2024ALIASSALES INVBN2032,000.00-8,000.00
403/11/2024ALIASBUYING RETURNS IBN34491,200.00-6,800.00
504/11/2024ALIASPAID VDF10001200.00-7,000.00
605/11/2024ALIASPAID VDF10002200.00-7,200.00
706/11/2024ALIASPAID VDF10003200.00-7,400.00
807/11/2024ALIASSALES INVBN2042,000.00-5,400.00
908/11/2024ALIASBUYING IBN34471,000.00-6,400.00
1009/11/2024ALIASBUYING RETURNS IBN34481,500.00-4,900.00
1110/11/2024ALIASRECEIVED VBF56692,000.00-2,900.00
12TOTAL8,700.0011,600.00-2,900.00
ASD
Cell Formulas
RangeFormula
F3:F11F3=F2+D3-E3
D12:E12D12=SUM(D2:D11)
F12F12=D12-E12




the result on form
fg1.PNG



rest of picture
fg2.PNG


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
 
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.​
1739120532840.png

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


😅
 
Last edited:
Upvote 0
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 !
 
Last edited:
Upvote 0
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.

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

🫡
 
Upvote 0
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

😅
 
Upvote 0
Solution

Forum statistics

Threads
1,226,771
Messages
6,192,918
Members
453,766
Latest member
Gskier

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