filter duplicates 7000 rows for 1000 names and insert new column to calculation

[Alaa mg]

Hello
I have about 1000 names ,could repeat for more than 7000 rows
so what I want put the data for the same name under each other of duplicates names and insert new column to calculation based on column B.
and should brings the balances from OPEN BALANCES for each name and put in first row for each name before filter data. and if there is no name in OPEN BALANCES sheet and it's existed in CUSTOMERS sheet ,then should show zero in column BALANCE.

er
	A	B	C	D	E	F
1	DATE	NAME	ORDER NO	CONDITION	DEBIT	CREDIT
2	06/02/2023	ALAA-1	ORD-001	N/H	20000
3	06/02/2023	ALAA-1	ORD-002	M/H	20000	1000
4	06/02/2023	ALAA-2	ORD-003	MM/N	10000
5	06/02/2023	ALAA-1	ORD-004	B/N	2000	100
6	06/02/2023	ALAA-1	ORD-004	B/NN	100
7	06/02/2023	ALAA-2	ORD-005	T/R	1000
8	06/02/2023	ALAA-3	ORD-006	MNG	1200
9	06/02/2023	ALAA-2	ORD-007	ITSR	1200	150
10	06/02/2023	ALAA-2	ORD-007	ITSRI	200	100
11	06/02/2023	ALAA-3	ORD-008	ITRE	200
12	06/02/2023	ALAA-3	ORD-009	ITRE	100
13	06/02/2023	ALAA-3	ORD-010	ITRE		100
14	06/02/2023	ALAA-3	ORD-011	ITRE	1000
15	06/02/2023	ALAA-3	ORD-012	ITRE	1200
16	06/02/2023	ALAA-3	ORD-013	ITRE		200
17	06/02/2023	ALAA-3	ORD-014	ITRE	100	50
CUSTOMERS

er
	A	B	C
1	ITEM	NAME	BALANCE
2	1	ALAA-1	1200
3	2	ALAA-2	-200
4
OPEN BALNCES

so when filter in RESULT sheet brings balance for each name from OPEN BALANCES and insert column BALANCE and calculation as I put the formula .


result

er
	A	B	C	D	E	F	G
1	DATE	NAME	ORDER NO	CONDITION	DEBIT	CREDIT	BALANCES
2	06/02/2023	ALAA-1		OPEN BALANCE	1200		1200
3	06/02/2023	ALAA-1	ORD-001	N/H	20000		21200
4	06/02/2023	ALAA-1	ORD-002	M/H	20000	1000	40200
5	06/02/2023	ALAA-1	ORD-004	B/N	2000	100	42100
6	06/02/2023	ALAA-1	ORD-004	B/NN	100		42200
7	06/02/2023	ALAA-2		OPEN BALANCE		-200	-200
8	06/02/2023	ALAA-2	ORD-003	MM/N	10000		9800
9	06/02/2023	ALAA-2	ORD-005	T/R	1000		10800
10	06/02/2023	ALAA-2	ORD-007	ITSR	1200	150	11850
11	09/02/2023	ALAA-2	ORD-007	ITSRI	200	100	11950
12	06/02/2023	ALAA-3		OPEN BALANCE			0
13	06/02/2023	ALAA-3	ORD-006	MNG	1200		1200
14	10/02/2023	ALAA-3	ORD-008	ITRE	200		1400
15	11/02/2023	ALAA-3	ORD-009	ITRE	100		1500
16	12/02/2023	ALAA-3	ORD-010	ITRE		100	1400
17	13/02/2023	ALAA-3	ORD-011	ITRE	1000		2400
18	14/02/2023	ALAA-3	ORD-012	ITRE	1200		3600
19	15/02/2023	ALAA-3	ORD-013	ITRE		200	3400
20	16/02/2023	ALAA-3	ORD-014	ITRE	100	50	3450
RESULT

Cell Formulas
Range	Formula
G13:G20,G8:G11,G3:G6	G3	=G2+E3-F3

if the balance for each name in OPEN BALANCES sheet is minus should put in CREDIT column and the same value put in BALANCE column ,if the balance for each name in OPEN BALANCES sheet is positive should put in DEBIT column and the same value put in BALANCE column and should write OPEN BALANCE in column D for the same row brings value from OPEN BALANCES sheet .
every time when run the macro should clear data in RESULT sheet.
thanks

 

[DanteAmor]

Try the following macro:

Sub Balances()
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim dic1 As Object, dic2 As Object
  Dim kys As String
  Dim i&, j&, k&, m&, nRow&, nCol&, y&
  Dim a, b, c, ky
  Dim openB As Double
  Dim rng As Range
  
  Set sh1 = Sheets("CUSTOMERS")
  Set sh2 = Sheets("OPEN BALANCES")
  Set sh3 = Sheets("RESULT")
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
  Set rng = sh3.Range("D1")
  
  a = sh1.Range("A2:F" & sh1.Range("B" & Rows.Count).End(3).Row).Value  'customers
  ReDim b(1 To UBound(a) * 2, 1 To 2000)                                'rows
  c = sh2.Range("A2:C" & sh2.Range("B" & Rows.Count).End(3).Row).Value  'open balances
  ReDim d(1 To UBound(a) * 2, 1 To 7)                                   'result
  
  For i = 1 To UBound(c)            'open balances
    dic1(c(i, 2)) = c(i, 3)
  Next

  For i = 1 To UBound(a, 1)         'customers
    kys = a(i, 2)
    If Not dic2.exists(kys) Then
      y = y + 1
      b(y, 1) = i
      dic2(kys) = y & "|" & 1
    Else
      nRow = Split(dic2(kys), "|")(0)
      nCol = Split(dic2(kys), "|")(1)
      nCol = nCol + 1
      b(nRow, nCol) = i
      dic2(kys) = nRow & "|" & nCol
    End If
  Next
  
  For Each ky In dic2.keys
    nRow = Split(dic2(ky), "|")(0)
    nCol = Split(dic2(ky), "|")(1)
    For j = 1 To nCol
      If j = 1 Then   'insert open balance
        k = k + 1
        d(k, 1) = a(b(nRow, j), 1)
        d(k, 2) = a(b(nRow, j), 2)
        d(k, 4) = "OPEN BALANCE"
        d(k, 7) = 0
        Set rng = Union(rng, sh3.Range("D" & k + 1))
        If dic1.exists(ky) Then
          openB = dic1(ky)
          If openB < 0 Then d(k, 6) = openB Else d(k, 5) = openB
          d(k, 7) = openB
        End If
      End If
      
      k = k + 1
      For m = 1 To 6
        d(k, m) = a(b(nRow, j), m)
      Next m
      d(k, 7) = d(k - 1, 7) + d(k, 5) - d(k, 6)
    Next j
  Next ky
  
  sh3.Range("2:" & Rows.Count).Clear
  sh1.Range("A1:F1").Copy sh3.Range("A1")
  sh1.Range("F1").Copy sh3.Range("G1")
  sh3.Range("G1").Value = "BALANCES"
  sh3.Range("A2").Resize(k, UBound(d, 2)).Value = d
  rng.Font.Bold = True
  sh3.Range("A:G").EntireColumn.AutoFit
  sh3.Range("A:G").HorizontalAlignment = xlCenter
End Sub

--------------
I hope to hear from you soon.
Respectfully
Dante Amor
--------------​

 

[DanteAmor]

Hi @Alaa mg :

Note:

If the name is correct, then wrap the name in this line of the macro:

Set sh2 = Sheets("OPEN BALANCES")

Comment the result of the macro and the time it takes to process.
Cordially
Dante Amor
--------------​

 

[Alaa mg]

Hi,
sorry about error in sheet name
your code works perfectly with small data ,but gives problem will delete the borders have already created manually and delete numbers formatting E: G
as to big data it gives subscript out of range in this line

 b(nRow, nCol) = i

I no know what's the problem . I will check it again
if you have any idea this could be useful .

 

[DanteAmor]

but gives problem will delete the borders

Change this line

sh3.Range("2:" & Rows.Count).Clear

To this:

sh3.Range("2:" & Rows.Count).ClearContents

----------------

as to big data it gives subscript out of range in this line

Change this line:

 ReDim b(1 To UBound(a) * 2, 1 To 2000)                                'rows

To this line:

 ReDim b(1 To UBound(a) * 2, 1 To UBound(a))                                'rows

----------------
I did a test with 7 thousand records in the "CUSTOMER" sheet and the result is in 2 seconds.

Comment how many records you have on each of your sheets.

 

[Alaa mg]

thanks for adjusting .

I did a test with 7 thousand records in the "CUSTOMER" sheet and the result is in 2 seconds.

OMG!!!
so my laptop is too much bad? !!
I'm shocked !
gives 81.30 sec for 7000 rows.

Comment how many records you have on each of your sheets.

the big data just be in CUSTOMER sheet more than 7000 rows and of course will increase ,others sheets don't increase at 2000 rows as maximum .