Delete customer if contains the same amount otherwise just subtract between two sheets

[Alaa mg]

Hi
I want deleting any name contains the same amount in NAMES sheet after comparison with BAD DEBTS sheet.
should match column C in NAMES sheet with column D in BAD DEBTS and search for the same amount in AMOUNT column then should delete the whole row for the customer , if doesn't contain the same amount in NAMES sheet after comparison with BAD DEBTS sheet then just subtract amount in NAMES sheet from BAD DEBTS sheet( be careful will repeat customers in BAD DEBTS so should merge amount for duplicate customer before delete the row if equal the same amount or subtraction.also should re autonumbering in column A and sum the AMOUNT column.
the result should be in PR.
I would macro to deal about big data for each sheet.

BAD DEBTS.xlsm
	A	B	C	D
1	ITEM	DETAILS	NAMES	AMOUNT
2	1	OPENING BALANCE 08/01/22	Ala	1,200.00
3	2	OPENING BALANCE 11/01/22	Aln	3,000.00
4	3	OPENING BALANCE 17/01/22	Alm	1,500.00
5	4	OPENING BALANCE 17/01/22	Alaa	1,200.00
6	5	OPENING BALANCE 17/01/22	Allia	1,000.00
7	6	OPENING BALANCE 17/01/22	Aliaa	1,100.00
8	7	OPENING BALANCE 17/01/22	Anila	1,500.00
9	8	OPENING BALANCE 17/01/22	Aali	1,000.00
10	9	OPENING BALANCE 17/01/22	Aml	1,100.00
11	TOTAL			12,600.00
NAMES

BAD DEBTS.xlsm
	A	B	C	D	E
1	ITEM	DATE	INVOICE NO	NAMES	AMOUNT
2	1	01/01/2024	INV AL-00	Ala	1,200.00
3	2	02/01/2024	INV AL-01	Aln	500.00
4	3	03/01/2024	INV AL-02	Aln	200.00
5	4	04/01/2024	INV AL-03	Alaa	200.00
6	5	05/01/2024	INV AL-04	Allia	200.00
7	6	06/01/2024	INV AL-05	Allia	800.00
BAD DEBTS

result

BAD DEBTS.xlsm
	A	B	C	D
1	ITEM	DETAILS	NAMES	AMOUNT
2	1	OPENING BALANCE 11/01/22	Aln	2,300.00
3	2	OPENING BALANCE 17/01/22	Alm	1,500.00
4	3	OPENING BALANCE 17/01/22	Alaa	1,000.00
5	4	OPENING BALANCE 17/01/22	Aliaa	1,100.00
6	5	OPENING BALANCE 17/01/22	Anila	1,500.00
7	6	OPENING BALANCE 17/01/22	Aali	1,000.00
8	7	OPENING BALANCE 17/01/22	Aml	1,100.00
9	TOTAL			9,500.00
RR

 

[igold]

I am sorry this line clears the formats-

wsRR.UsedRange.Offset(1, 0).Clear

you can change it to

wsRR.UsedRange.Offset(1, 0).ClearContents

but that will leave you with a stray yellow highlight. I can try to modify the code to take that Yellow highlight out but I can't get to it right now...

 

[Alaa mg]

still delete borders .

but that will leave you with a stray yellow highlight

yes I see that.

I can try to modify the code to take that Yellow highlight out but I can't get to it right now.

no problem take your time . you can do that tomorrow if it's late time in your location.

 

[igold]

Try adding this as the next line below the line referenced in my post #11

.UsedRange.Offset(1, 0).Interior.Color = -4142

Try re-formatting the RR tab the way you would like and run the code again with the above line placed where indicated and the line above to read .clearcontents.

although there is nothing in the code to create new border, so that will still be an issue. I will be able to work the borders a little later, but this new line should clear the previous yellow highlight.

 

[igold]

How about this for a complete code:

Sub Sum_Values2()

    Dim wsN As Worksheet: Set wsN = Worksheets("Names")
    Dim wsBD As Worksheet: Set wsBD = Worksheets("BAD DEBTS")
    Dim wsRR As Worksheet: Set wsRR = Worksheets("RR")
    Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
    Dim a, arr, arr2, arr3, nams, rng As Range
    Dim r As Long, c As Long, i As Long, ct As Long, x As Long, d As String, lRow As Long
    Dim hdr
    
    Application.ScreenUpdating = False
    wsN.Activate
    a = wsBD.Range("D2:E" & Cells(Rows.Count, 4).End(xlUp).Row)
    nams = wsN.Range("A2:D" & Cells(Rows.Count, 3).End(xlUp).Row)
    ct = 1
    For i = 1 To UBound(a)
          dic(a(i, 1)) = dic(a(i, 1)) + a(i, 2)
    Next

    ReDim arr3(1 To dic.Count, 1 To 2)
    ReDim res(1 To UBound(nams), 1 To 4)

    arr = dic.keys
    arr2 = dic.items
    For r = 1 To UBound(arr) + 1
        arr3(r, 1) = arr(r - 1)
        arr3(r, 2) = arr2(r - 1)
    Next

    For c = 1 To UBound(nams)
        For x = 1 To UBound(arr3)
            If nams(c, 3) = arr3(x, 1) Then
                    nams(c, 4) = nams(c, 4) - arr3(x, 2)
                    If nams(c, 4) = 0 Then nams(c, 4) = ""
            End If
        Next
    Next
    hdr = Array("ITEM", "DETAILS", "NAMES", "AMOUNT")
    With wsRR
        .Activate
        .UsedRange.Offset(1, 0).ClearContents
        .UsedRange.Offset(1, 0).Interior.Color = -4142
        .UsedRange.HorizontalAlignment = -4108
        .Range("A2").Resize(UBound(nams, 1), UBound(nams, 2)) = nams
        lRow = wsRR.Cells(Rows.Count, 3).End(xlUp).Row
        .Range("A2").Formula = "=ROW()-1"
        .Range("A2").AutoFill wsRR.Range("A2:A" & lRow)
        .Range("D2:D" & lRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        lRow = wsRR.Cells(Rows.Count, 3).End(xlUp).Row
        .Range("A" & lRow + 1) = "TOTAL"
        Set rng = wsRR.Range("D2:D" & lRow)
        d = rng.Address(False, False)
        x = WorksheetFunction.Sum(Range(d))
        .Range("D" & lRow + 1) = x
        .Range("A" & lRow + 1 & ":D" & lRow + 1).Interior.Color = RGB(255, 255, 0)
        .Range("A1:D1") = hdr
        .Range("A1:D1").Interior.Color = RGB(255, 255, 0)
    End With
    With wsRR.Range("A1:D" & lRow + 1).Borders
        .LineStyle = xlContinuous
    End With
    Application.ScreenUpdating = True
    
End Sub

 

[Alaa mg]

sorry for delaying !
the code works perfectly .
thank you so much.

 

[igold]

You're welcome, I was happy to help. Thanks for the feedback!