create list by extract amounts for the last row for each sheet name

[Alaa mg]

hello
I need extract amount for each sheet based on last row for each name .
in column B should merge date for the last row with OPENING BALANCE word for each name , column C should populate name based on sheet name , column D should brings amount from the last row in column E
and will add new sheets before BALANCES sheet and will add new data for each sheet ,then should replace new data for old data by delete data have already copied in BALANCES sheet when every time add new data in others sheets.
if there is macro will be great.
thanks

asq
	A	B	C	D	E
1	DATE	Describe	DEBIT	CREDIT	BALANCE
2	05/01/2022	NOT PAID	1233		1233
3	06/01/2022	NOT PAID	1233		2466
4	07/01/2022	PAID		2000	466
5	08/01/2022	PAID		400	66
ALA

asq
	A	B	C	D	E
1	DATE	Describe	DEBIT	CREDIT	BALANCE
2	08/01/2022				0
3	09/01/2022	NOT PAID	2000		2000
4	11/01/2022	NOT PAID	2000	1000	3000
5	11/01/2022	NOT PAID	2000	4000	1000
ALN

asq
	A	B	C	D	E
1	DATE	Describe	DEBIT	CREDIT	BALANCE
2	11/01/2022				0
3	12/01/2022	NOT PAID	1500		1500
4	13/01/2022	NOT PAID	500		2000
5	14/01/2022	PAID	2000	1000	3000
6	15/01/2022	PAID		1010	1990
7	16/01/2022	PAID		1000	990
8	17/01/2022	PAID		990	0
ALM

result


before

asq
	A	B	C	D
1	ITEM	DETAILES	NAMES	AMOUNT
2
3
4
5
6
7
8
9
10
11
12
BALANCES

after

asq
	A	B	C	D
1	ITEM	DETAILES	NAMES	AMOUNT
2	1	OPENING BALANCE 08/01/2022	ALA	66
3	2	OPENING BALANCE 11/01/2022	ALN	1000
4	3	OPENING BALANCE 17/01/2022	ALM	0
5
6
7
8
9
10
11
12
BALANCES

 

[OaklandJim]

I hope that THIS WORKBOOK does what is needed.

Option Explicit

' ----------------------------------------------------------------
' Procedure Name: TransferOpeningBalances
' Purpose: Fill current balances worksheet.
' Procedure Kind: Sub
' Procedure Access: Public
' Author: Jim
' Date: 6/25/2023
' ----------------------------------------------------------------

Sub TransferOpeningBalances()

'   -----------------------------------
'           Declare Variables
'   -----------------------------------

'   Used to iterate through all worksheets.
    Dim wsLoop As Worksheet
    
'   The summary worksheet including Opening Balances for all names.
    Dim wsBalances As Worksheet

'   Cell address of upperleftmost cell in names data. It contains the header label.
    Dim sNamesAnchorCellAddress As String

'   Cell address of upperleftmost cell in Balanaces worksheet data. It contains the header label.
    Dim sBalancesAnchorCellAddress As String
    
'   Range object variable for upperleftmost cell in names worksheet.
    Dim rNamesAnchorCell As Range
    
'   Range object variable for upperleftmost cell in Balances worksheet.
    Dim rBalancesAnchorCell As Range
    
'   Used to hold the value for the last row in the data.
    Dim iLastDataRow As Long
    
'   Used to hold the value for the next available row in the Balances data.
    Dim iNextBalanceRow As Long
    
'   The date to transfer from person data worksheet to Balances data worksheet.
    Dim dDate As Date
    
'   The balance to transfer from person data worksheet to Balances data worksheet.
    Dim dBalance As Double
    
'   The name to transfer from person data worksheet to Balances data worksheet.
    Dim sName As String
    
'   Keep track of how many names have been added to the Balances worksheet.
    Dim iNames As Long
    
'   -----------------------------------
'         Initialize Variables
'   -----------------------------------
    
    sNamesAnchorCellAddress = "A1" '<= Change if upperleftmost (header) cell for data in
'                                      the Name worksheets changes.
    
    sBalancesAnchorCellAddress = "A1" '<= Change if upperleftmost (header) cell for data in
'                                         the BALANCES worksheets changes.
    
    Set wsBalances = Worksheets("BALANCES") '<= Change if name of BALANCES worksheet changes.
    
    Set rBalancesAnchorCell = wsBalances.Range(sBalancesAnchorCellAddress)
    
'   -----------------------------------
'       Clear Exising Balances Data
'   -----------------------------------
    
    iLastDataRow = wsBalances.Cells(Rows.Count, 1).End(xlUp).Row
        
'   Remove alternating row shading from Balances worksheet.
'   If there are no rows to process this causes an error. If
'   so then skip over the command.
    On Error Resume Next
    With rBalancesAnchorCell.Offset(1).Resize(iLastDataRow - 1, 4)
        .Value = ""
        .FormatConditions.Delete
    End With
    On Error GoTo 0
'   -----------------------------------
'           Process Names Data
'   -----------------------------------
    
'   Iterate through all worksheets.
    For Each wsLoop In Worksheets

'       Only process worksheets with a person's data. This assumes that there are no other
'       worksheets except name-specific person's data worksheets and BALANCES worksheet!
        If UCase(wsLoop.Name) <> UCase(wsBalances.Name) _
         Then
            Set rNamesAnchorCell = wsLoop.Range(sNamesAnchorCellAddress)
            
            iLastDataRow = wsLoop.Cells(Rows.Count, 1).End(xlUp).Row
                  
            dDate = rNamesAnchorCell.Cells(iLastDataRow, 1).Value
            
            dBalance = rNamesAnchorCell.Cells(iLastDataRow, 5).Value
            
'           Name to transfer to the Balances worksheet is based on the worksheet name
'           for a specific person.
            sName = wsLoop.Name
            
'           Increment count of names transferred to the Balances worksheet.
            iNames = iNames + 1
            
            With rBalancesAnchorCell
            
'               Put item/name number into first column.
                .Cells(iNames + 1, 1) = iNames
                
'               Put OPENING BALANCE dd/mm/yy into second column.
                .Cells(iNames + 1, 2) = "OPENING BALANCE " & Format(dDate, "dd/mm/yy")
            
'               Put name into third column.
                .Cells(iNames + 1, 3) = sName
            
'               Put balance into fourth column.
                .Cells(iNames + 1, 4) = dBalance
            
            End With
                     
        End If
            
    Next wsLoop
    
'   ------------------------------------------------
'       Conditional Formatting of Balances Data
'   ------------------------------------------------

'   This code adds conditional formatting that creates alternating rows formatting.
    iLastDataRow = wsBalances.Cells(Rows.Count, 1).End(xlUp).Row

    With rBalancesAnchorCell.Offset(1).Resize(iLastDataRow - 1, 4)
    
        .FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(ROW(),2)=1"
        
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        
        With .FormatConditions(1).Interior
            .Pattern = xlGray16
            .PatternThemeColor = xlThemeColorDark1
            .ColorIndex = xlAutomatic
            .PatternTintAndShade = -0.349986266670736
        End With
        
        .FormatConditions(1).StopIfTrue = False
    
    End With

End Sub

 

[RudRud]

Book1
	A	B	C	D
1	ITEM	DETAILES	NAMES	AMOUNT
2	1	OPENING BALANCE 1/8/2022	ALA	66
3	2	OPENING BALANCE 1/11/2022	ALN	1000
4	3	OPENING BALANCE 1/17/2022	ALM	0
BALANCES

After putting the names, dates and last row values into balance sheets, what's your next step? Can you elaborate further more? Thank you

Below code will loop through all worksheets (Except Balances sheet) , finding last row,date, sheet name values and put into balances sheet

Option Explicit
Option Compare Text
Sub test()
Dim i%, lrow%, k%
Dim a()
Dim b()
ReDim b(1 To 10000, 1 To 4)

Sheets("BALANCES").[a2:d10000].Clear


For i = 1 To Worksheets.Count
      With Sheets(i)
            If Sheets(i).Name <> "BALANCES" Then 'Loop except balances sheet
             lrow = .Cells(Rows.Count, "e").End(xlUp).Row 'Find the last row of the sheets value
             a = .Range(.Cells(lrow, "A"), .Cells(lrow, "e")).Value 'Store last row into array
             k = k + 1
             b(k, 1) = k
             b(k, 2) = "OPENING BALANCE " & a(1, 1) 'Date value
             b(k, 3) = Sheets(i).Name
             b(k, 4) = a(1, 5) 'Balance Value
             End If
      End With
Next i
      Sheets("BALANCES").[a2].Resize(UBound(b, 1), UBound(b, 2)).Value = b 'Call out Array
End Sub

 

[Alaa mg]

@OaklandJim
thanks
it automates error invalid procedure call or argument in this line

.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(ROW(),2)=1"

 

[Alaa mg]

@RudRud
I no know what you ask for it !
your code works as I expect, but I forgot something ,sorry!
should insert Total row like this

NamesBalances.xlsm
	A	B	C	D
1	ITEM	DETAILS	NAMES	AMOUNT
2	1	OPENING BALANCE 08/01/22	ALA	66.00
3	2	OPENING BALANCE 11/01/22	ALN	1,000.00
4	3	OPENING BALANCE 17/01/22	ALM	0.00
5	TOTAL			1,066.00
BALANCES

Cell Formulas
Range	Formula
D5	D5	=SUM(D2:D4)

 

[RudRud]

Book4
	A	B	C	D
1	ITEM	DETAILES	NAMES	AMOUNT
2	1	OPENING BALANCE 1/8/2022	ALA	66
3	2	OPENING BALANCE 1/7/2022	Sheet5	466
4	3	OPENING BALANCE 1/11/2022	ALN	1000
5	4	OPENING BALANCE 1/17/2022	ALM	0
6	TOTAL			1532
BALANCES

Option Explicit
Option Compare Text
Sub test()
Dim i%, lrow%, k%, ttl%
Dim a()
Dim b()
ReDim b(1 To 10000, 1 To 4)

Sheets("BALANCES").[a2:d10000].Clear


For i = 1 To Worksheets.Count
      With Sheets(i)
            If Sheets(i).Name <> "BALANCES" Then 'Loop except balances sheet
             lrow = .Cells(Rows.Count, "e").End(xlUp).Row 'Find the last row of the sheets value
             a = .Range(.Cells(lrow, "A"), .Cells(lrow, "e")).Value 'Store last row into array
             k = k + 1
             b(k, 1) = k
             b(k, 2) = "OPENING BALANCE " & a(1, 1) 'Date value
             b(k, 3) = Sheets(i).Name
             b(k, 4) = a(1, 5) 'Balance Value
             ttl = a(1, 5) + ttl
             End If
      End With
    
Next i
With Sheets("BALANCES")
    .[a2].Resize(UBound(b, 1), UBound(b, 2)).Value = b 'Call out Array
    lrow = .Cells(Rows.Count, "a").End(xlUp).Row + 1
    .Cells(lrow, "A").Value = "TOTAL"
    .Cells(lrow, "d").Value = ttl
End With
  
End Sub

 

[Alaa mg]

@RudRud
thank you so much .

 

[RudRud]

@RudRud
thank you so much .

Glad to assist, If you have any further questions, please don't hesitate to ask/share with us