Extract last amounts in column within two dates

[abdo meghari]

Hello,
I want to extract amounts is existed in column F within two dates

ورقة عمل Microsoft Excel جديد ‫‬.xlsx
	A	B	C	D	E	F	G	H	I	J	K
1	DATE	INFO	DEBIT	CREDIT	BALANCE	NOTE		ITEM	FROM DATE	TO DATE	AMOUNT
2	01/11/2024	SALES INVOICE NO BSJ2000	2000		2000
3	02/11/2024	SALES INVOICE NO BSJ2001	3000		5000
4	03/11/2024	SALES RETURNS INVOICE NO BSJ789		3000	2000
5	03/11/2024	VOUCHER NO VBGH6788		1500	500
6	04/11/2024	SALES INVOICE NO BSJ2003	15000		15500
7	04/11/2024	SALES INVOICE NO BSJ2004	8485		23985	28,485.000
8	05/11/2024	SALES INVOICE NO BSJ2005	12000		35985
9	06/11/2024	SALES INVOICE NO BSJ2006	12000		47985	24,000.000
ACOOUNT

Cell Formulas
Range	Formula
E2	E2	=C2-D2
E3,E5:E9	E3	=E2+C3-D3
E4	E4	=E3+CC104-D4

result

ورقة عمل Microsoft Excel جديد ‫‬.xlsx
	A	B	C	D	E	F	G	H	I	J	K
1	DATE	INFO	DEBIT	CREDIT	BALANCE	NOTE		ITEM	FROM DATE	TO DATE	AMOUNT
2	01/11/2024	SALES INVOICE NO BSJ2000	2000		2000			1	01/11/2024	04/11/2024	28,485.000
3	02/11/2024	SALES INVOICE NO BSJ2001	3000		5000			2	05/11/2024	06/11/2024	24,000.000
4	03/11/2024	SALES RETURNS INVOICE NO BSJ789		3000	2000			TOTAL			52,485.000
5	03/11/2024	VOUCHER NO VBGH6788		1500	500
6	04/11/2024	SALES INVOICE NO BSJ2003	15000		15500
7	04/11/2024	SALES INVOICE NO BSJ2004	8485		23985	28,485.000
8	05/11/2024	SALES INVOICE NO BSJ2005	12000		35985
9	06/11/2024	SALES INVOICE NO BSJ2006	12000		47985	24,000.000
ACOOUNT

Cell Formulas
Range	Formula
K4	K4	=SUM(K2:K3)
E2	E2	=C2-D2
E3,E5:E9	E3	=E2+C3-D3
E4	E4	=E3+CC104-D4

so should copy every amount is existed in column F with two dates and insert TOTAL row to sum amount column .and should delete data before brings report in range H:K
thanks

 

[Peter_SSs]

Give this a try with a copy of your worksheet.

Sub Extract_Amounts()
  Dim a As Variant, b As Variant
  Dim k As Long, i As Long
  
  Intersect(ActiveSheet.UsedRange.EntireRow, Columns("H:K")).Offset(1).Clear
  a = Range("A1").CurrentRegion.Value
  ReDim b(1 To UBound(a), 1 To 4)
  For i = 2 To UBound(a)
    If Len(a(i - 1, 6)) > 0 Then
      k = k + 1
      b(k, 1) = k: b(k, 2) = a(i, 1)
    End If
    If Len(a(i, 6)) > 0 Then
      b(k, 3) = a(i, 1): b(k, 4) = a(i, 6)
    End If
  Next i
  With Range("H2:K2")
    .Resize(k).Value = b
    With .Offset(k)
      .FormulaR1C1 = Array("TOTAL", "", "", "=sum(R2C:R[-1]C)")
      .Cells(1).Interior.Color = vbYellow
      .Cells(1).Font.Bold = True
    End With
  End With
End Sub

 

[abdo meghari]

Great!
just I need fixing the formatting .
I would add borders around cells and show number format like this "#,##0.00" in range H:K also show data in the center.

 

[Peter_SSs]

just I need fixing the formatting .

Format H1:K1 manually as this does not get changed by the code then try this version

Sub Extract_Amounts_v2()
  Dim a As Variant, b As Variant
  Dim k As Long, i As Long
  
  Intersect(ActiveSheet.UsedRange.EntireRow, Columns("H:K")).Offset(1).Clear
  a = Range("A1").CurrentRegion.Value
  ReDim b(1 To UBound(a), 1 To 4)
  For i = 2 To UBound(a)
    If Len(a(i - 1, 6)) > 0 Then
      k = k + 1
      b(k, 1) = k: b(k, 2) = a(i, 1)
    End If
    If Len(a(i, 6)) > 0 Then
      b(k, 3) = a(i, 1): b(k, 4) = a(i, 6)
    End If
  Next i
  With Range("H2:K2").Resize(k + 1)
    .Value = b
    .BorderAround xlContinuous
    .Borders(xlInsideVertical).LineStyle = xlContinuous
    .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    With .Rows(k + 1)
      .FormulaR1C1 = Array("TOTAL", "", "", "=sum(R2C:R[-1]C)")
      .Cells(1).Interior.Color = vbYellow
      .Cells(1).Font.Bold = True
    End With
    .Columns(4).NumberFormat = "#,##0.00"
  End With
End Sub

 

[abdo meghari]

when I put the data in center manually the code will move it for the right !

 

[Peter_SSs]

when I put the data in center manually the code will move it for the right !

Sorry, I missed that point you mentioned in post 3.

Sub Extract_Amounts_v3()
  Dim a As Variant, b As Variant
  Dim k As Long, i As Long
  
  Intersect(ActiveSheet.UsedRange.EntireRow, Columns("H:K")).Offset(1).Clear
  a = Range("A1").CurrentRegion.Value
  ReDim b(1 To UBound(a), 1 To 4)
  For i = 2 To UBound(a)
    If Len(a(i - 1, 6)) > 0 Then
      k = k + 1
      b(k, 1) = k: b(k, 2) = a(i, 1)
    End If
    If Len(a(i, 6)) > 0 Then
      b(k, 3) = a(i, 1): b(k, 4) = a(i, 6)
    End If
  Next i
  With Range("H2:K2").Resize(k + 1)
    .Value = b
    .BorderAround xlContinuous
    .Borders(xlInsideVertical).LineStyle = xlContinuous
    .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    .HorizontalAlignment = xlCenter
    With .Rows(k + 1)
      .FormulaR1C1 = Array("TOTAL", "", "", "=sum(R2C:R[-1]C)")
      .Cells(1).Interior.Color = vbYellow
      .Cells(1).Font.Bold = True
    End With
    .Columns(4).NumberFormat = "#,##0.00"
  End With
End Sub

 

[abdo meghari]

Excellent !
everything is ok .
many thanks for help.

 

[Peter_SSs]

You're welcome. Thanks for the confirmation.