Extraction last row based on specific words and put in account column(debit,credit)

[Alaa mg]

Hello,
I have data about 8000 rows for each sheet .
every sheet should search for CASH, BANK words then should extract amount in TOTAL row for each word and put in column DEBIT or CREDIT and calculation in column BALANCE in RESULT sheet.

ALLAA.xlsm
	A	B	C	D	E	F	G
1	DATE	BATCH	NAME	ACRRUING/CASH	QTY	PRICE	BALANCE
2	01/01/2024	GHTR-00	ALAA	ACRRUING	20.00	220.00	4,400.00
3	01/01/2024	GHTR-01	ALAA	ACRRUING	10.00	214.00	2,140.00
4	01/01/2024	GHTR-02	ALAA	ACRRUING	12.00	215.00	2,580.00
5	TOTAL						9,120.00
6	01/01/2024	GHTR-00	ALAA	CASH IN CS200	10.00	200.00	2,000.00
7	TOTAL						2,000.00
8	01/01/2024	GHTR-00	ALA1	BANK IN BN2000	10.00	200.00	2,000.00
9	TOTAL						2,000.00
10	01/01/2024	GHTR-01	ALAA	CASH IN CS2001	5.00	200.00	1,000.00
11	01/01/2024	GHTR-02	ALAA	CASH IN CS2001	10.00	210.00	2,100.00
12	TOTAL						3,100.00
SDFR

Cell Formulas
Range	Formula
G2:G4	G2	=E2*F2

ALLAA.xlsm
	A	B	C	D	E	F	G
1	DATE	BATCH	NAME	ACRRUING/CASH	QTY	PRICE	BALANCE
2	01/01/2024	GHTR-02	LAAL	CASH IN CS204	1.00	230.00	230.00
3	01/01/2024	GHTR-00	LAAL	CASH IN CS204	2.00	250.00	500.00
4	TOTAL						730.00
5	01/01/2024	GHTR-00	AMINA	CASH IN CS205	1.00	200.00	200.00
6	01/01/2024	GHTR-01	AMINA	CASH IN CS205	2.00	270.00	540.00
7	01/01/2024	GHTR-02	AMINA	CASH IN CS205	1.00	300.00	300.00
8	TOTAL						1,040.00
9	01/01/2024	GHTR-02	ALA1	BANK IN BN2001	2.00	310.00	620.00
10	TOTAL						620.00
11	01/01/2024	GHTR-01	ALAA	ACRRUING	2.00	200.00	400.00
12	01/01/2024	GHTR-02	ALAA	ACRRUING	3.00	210.00	630.00
13	TOTAL						1,030.00
BGHT

ALLAA.xlsm
	A	B	C	D	E	F	G
1	DATE	BATCH	NAME	ACRRUING/CASH	QTY	PRICE	BALANCE
2	01/01/2024	GHTR-02	ALAA	ACRRUING	1.00	215.00	215.00
3	TOTAL						215.00
4	01/01/2024	GHTR-00	ALAA	CASH IN CS203	1.00	200.00	200.00
5	TOTAL						200.00
6	01/01/2024	GHTR-00	ALA1	BANK IN BN2002	2.00	200.00	400.00
7	TOTAL						400.00
8	02/01/2024	GHTR-01	ALAA	CASH IN CS2003	2.00	200.00	400.00
9	02/01/2024	GHTR-02	ALAA	CASH IN CS2003	3.00	210.00	630.00
10	TOTAL						1,030.00
BTRT

Cell Formulas
Range	Formula
G2	G2	=E2*F2

ALLAA.xlsm
	A	B	C	D	E	F	G
1	DATE	BATCH	NAME	ACRRUING/CASH	QTY	PRICE	BALANCE
2	01/01/2024	GHTR-02	LAAL	CASH IN CS206	1.00	230.00	230.00
3	01/01/2024	GHTR-00	LAAL	CASH IN CS206	1.00	250.00	250.00
4	TOTAL						480.00
5	01/01/2024	GHTR-00	AMINA	CASH IN CS207	1.00	200.00	200.00
6	01/01/2024	GHTR-01	AMINA	CASH IN CS207	2.00	270.00	540.00
7	01/01/2024	GHTR-02	AMINA	CASH IN CS207	1.00	300.00	300.00
8	TOTAL						1,040.00
9	01/01/2024	GHTR-02	ALA1	BANK IN BN2004	2.00	310.00	620.00
10	TOTAL						620.00
11	02/01/2024	GHTR-00	AMINA	ACRRUING	1.00	200.00	200.00
12	02/01/2024	GHTR-01	AMINA	ACRRUING	1.00	270.00	270.00
13	02/01/2024	GHTR-02	AMINA	ACRRUING	1.00	300.00	300.00
14	TOTAL						770.00
BFGT

ALLAA.xlsm
	A	B	C	D	E	F
1	DATE	S.N	ACRRUING/CASH	DEBIT	CREDIT	BALANCE
2
3
4
5
6
7
8
9
10
11
12
13
14
RESULT

I want this

ALLAA.xlsm
	A	B	C	D	E	F
1	DATE	S.N	ACRRUING/CASH	DEBIT	CREDIT	BALANCE
2	01/01/2024	1	CASH IN CS200	2,000.00		2,000.00
3	01/01/2024	2	BANK IN BN2000	2,000.00		4,000.00
4	01/01/2024	3	CASH IN CS2001	3,100.00		7,100.00
5	01/01/2024	4	CASH IN CS204		730.00	6,370.00
6	01/01/2024	5	CASH IN CS205		1,040.00	5,330.00
7	01/01/2024	6	BANK IN BN2001		620.00	4,710.00
8	01/01/2024	7	CASH IN CS203	200.00		4,910.00
9	01/01/2024	8	BANK IN BN2002	400.00		5,310.00
10	02/01/2024	9	CASH IN CS2003	1,030.00		6,340.00
11	01/01/2024	10	CASH IN CS206		480.00	5,860.00
12	01/01/2024	11	CASH IN CS207		1,040.00	4,820.00
13	01/01/2024	12	BANK IN BN2004		620.00	4,200.00
14	TOTAL			8,730.00	4,530.00	4,200.00
RESULT

Cell Formulas
Range	Formula
F2,F14	F2	=D2-E2
F3:F13	F3	=F2+D3-E3
D14:E14	D14	=SUM(D2:D13)

as you see for first,third sheets will put amount in DEBIT column as to second,fourth sheets will put in CREDIT column and insert TOTAL row to sum columns for debit,credit.
will bring date and ACRRUING/CASH columns and auto numbering in column B
every time should replace data when run the code.
I don't want solution by POWER QUERY ,PIVOT TABLE , FORMULAS . just I want code
thanks

 

[DanteAmor]

Try:

Sub Extraction_based_specific_words()
  Dim arr As Variant, sht As Variant
  Dim sh As Worksheet
  Dim ar As Range
  Dim i As Long, k As Long, nRows As Long, lr As Long
  Dim bce As Double, dbt As Double, cdt As Double
  
  Application.ScreenUpdating = False
  arr = Array("SDFR", "BGHT", "BTRT", "BFGT")   '1,2 and 3,4
  
  For i = 0 To UBound(arr)
    Set sh = Sheets(arr(i))
    nRows = nRows + sh.Range("A" & Rows.Count).End(3).Row
  Next
  ReDim b(1 To nRows, 1 To 6)
  
  For i = 0 To UBound(arr)
    Set sh = Sheets(arr(i))
  
    For Each ar In sh.Range("D2:D" & sh.Range("A" & Rows.Count).End(3).Row).SpecialCells(xlCellTypeBlanks).Areas
      If InStr(1, ar.Offset(-1).Value, "CASH", vbTextCompare) > 0 Or _
         InStr(1, ar.Offset(-1).Value, "BANK", vbTextCompare) > 0 Then
        k = k + 1
        b(k, 1) = ar.Offset(-1, -3).Value
        b(k, 2) = k
        b(k, 3) = ar.Offset(-1, 0).Value
        If i = 0 Or i = 2 Then
          b(k, 4) = ar.Offset(0, 3).Value
          dbt = dbt + b(k, 4)
        Else
          b(k, 5) = ar.Offset(0, 3).Value
          cdt = cdt + b(k, 5)
        End If
        bce = bce + b(k, 4) - b(k, 5)
        b(k, 6) = b(k, 6) + bce
        Sheets("RESULT").Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
      End If
    Next
  Next
  
  With Sheets("RESULT")
    .Range("A2:F" & Rows.Count).Clear
    .Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
    lr = .Range("A" & Rows.Count).End(3).Row + 1
    .Range("A" & lr).Resize(1, 6).Value = Array("TOTAL", , , dbt, cdt, dbt - cdt)
    .Range("A:A").NumberFormat = "dd/mm/yyyy"
    .Range("D:F").NumberFormat = "#,##0.00"
    .Range("A:F").HorizontalAlignment = xlCenter
    Range("A2:F" & lr).Borders.LineStyle = xlContinuous
  End With
  
  Application.ScreenUpdating = True
End Sub

 

[Alaa mg]

the code works perfect with small data , but I'm afraid will be too slow with data for about 6000 rows at least for each sheet !
did you test it?
do you have another efficient way?

 

[DanteAmor]

the code works perfect

do you have another efficient way?

Of course, with matrices:

Sub Extraction_based_specific_words()
  Dim arr As Variant, sht As Variant
  Dim sh As Worksheet
  Dim ar As Range
  Dim i As Long, j As Long, k As Long, nRows As Long, lr As Long
  Dim bce As Double, dbt As Double, cdt As Double
  Dim a() As Variant, b As Variant
  
  Application.ScreenUpdating = False
  arr = Array("SDFR", "BGHT", "BTRT", "BFGT")   '1,2 and 3,4
  
  For i = 0 To UBound(arr)
    Set sh = Sheets(arr(i))
    nRows = nRows + sh.Range("A" & Rows.Count).End(3).Row
  Next
  ReDim b(1 To nRows, 1 To 6)
  
  For j = 0 To UBound(arr)
    Set sh = Sheets(arr(j))
    Erase a
    a = sh.Range("A1", sh.Range("G" & Rows.Count).End(3)).Value2
    For i = 2 To UBound(a, 1)
      If a(i, 1) = "TOTAL" Then
        If InStr(1, a(i - 1, 4), "CASH", vbTextCompare) > 0 Or _
           InStr(1, a(i - 1, 4), "BANK", vbTextCompare) > 0 Then
          k = k + 1
          b(k, 1) = a(i - 1, 1)
          b(k, 2) = k
          b(k, 3) = a(i - 1, 4)
          If j = 0 Or j = 2 Then
            b(k, 4) = a(i, 7)
            dbt = dbt + b(k, 4)
          Else
            b(k, 5) = a(i, 7)
            cdt = cdt + b(k, 5)
          End If
          bce = bce + b(k, 4) - b(k, 5)
          b(k, 6) = b(k, 6) + bce
        End If
      End If
    Next
  Next
  
  With Sheets("RESULT")
    .Range("A2:F" & Rows.Count).Clear
    .Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
    lr = .Range("A" & Rows.Count).End(3).Row + 1
    .Range("A" & lr).Resize(1, 6).Value = Array("TOTAL", , , dbt, cdt, dbt - cdt)
    .Range("A:A").NumberFormat = "dd/mm/yyyy"
    .Range("D:F").NumberFormat = "#,##0.00"
    .Range("A:F").HorizontalAlignment = xlCenter
    Range("A2:F" & lr).Borders.LineStyle = xlContinuous
  End With
  
  Application.ScreenUpdating = True
End Sub

 

[Alaa mg]

This is really better !
much appreciated for your help.