Assistance Needed with Excel VBA Code for Color Formatting

[malkoriche]

I need help with my code as I'm unable to get the colors at the end. I would appreciate it if someone could solve the problem.

The code iterates through each row in the specified data range.For each row, it checks if the keywords "beneficiary" and "sender" are present in column G (Description).If the keywords are found, the code retrieves the sender, beneficiary, and the corresponding amount (debit or credit).Next, it searches for a matching row within the data range where the beneficiary and sender are swapped.If a match is found, the code compares the debit and credit amounts.If the amounts match, it colors the debit or credit cell of the current row in green and the corresponding cell in the other row in green as well.If the amounts don't match, it colors the debit or credit cell of the current row in orange and the corresponding cell in the other row in orange as well.This visually highlights the matches and discrepancies between the debited and credited amounts in the Excel file.

Here are the columns used in the code:

Column G: Description (to search for keywords)Column A: SenderColumn D: BeneficiaryColumn L: Debit AmountColumn M: Credit Amount

Here is the code:

Sub BalanceThirdPartyAccounts()
Dim rng As Range
Dim cell As Range
Dim beneficiary As String
Dim sender As String
Dim amount As Double
Dim correspondingCell As Range

' Prompt the user to select the range of data to check
On Error Resume Next
Set rng = Application.InputBox("Select the range of data to check:", Type:=8)
On Error GoTo 0

' Check if the user cancelled the selection
If rng Is Nothing Then
MsgBox "Operation cancelled."
Exit Sub
End If

' Iterate through each cell in the specified range
For Each cell In rng
' Get the value of the cell in column G (Description)
Dim description As String
description = cell.Offset(0, 6).Value

' Search for keywords in the description
If InStr(1, description, "beneficiary", vbTextCompare) > 0 And InStr(1, description, "sender", vbTextCompare) > 0 Then
' Get the sender and beneficiary
sender = cell.Offset(0, -6).Value
beneficiary = cell.Offset(0, -9).Value

' Search for the corresponding amount (debit or credit)
For Each correspondingCell In rng
If correspondingCell.Value = beneficiary And correspondingCell.Offset(0, -6).Value = sender Then
' Check if the amount is in the debit column (L)
If Not IsEmpty(correspondingCell.Offset(0, -2).Value) Then
amount = correspondingCell.Offset(0, -2).Value ' Found debited amount
Else
amount = correspondingCell.Offset(0, -1).Value ' Found credited amount
End If
Exit For
End If
Next correspondingCell

' Check if the debited amount matches the credited amount
If Abs(amount - cell.Offset(0, 12).Value) < 0.01 Then
' The amount is balanced, color the debit cell in green
correspondingCell.Offset(0, -2).Interior.Color = RGB(0, 255, 0) ' Green
' Color the credit cell in green
cell.Offset(0, 12).Interior.Color = RGB(0, 255, 0) ' Green
Else
' There is a difference, color the debit cell in orange
correspondingCell.Offset(0, -2).Interior.Color = RGB(255, 165, 0) ' Orange
' Color the credit cell in orange
cell.Offset(0, 12).Interior.Color = RGB(255, 165, 0) ' Orange
End If
End If
Next cell
End Sub

 

[DacEasy]

Do you have any sample data to test the code against?

 

[malkoriche]

 

[malkoriche]

Sender/Receiver	DATE	NOTE IMPORTANT	Receiver/Sender	NOT IMPORTANT	NOTE IMPORTANT2	DESCRIPTION	DEBIT	CREDIT
nicolas			sarah			nicolas send to sarah	300,00​
John			William			John receive from WILLIAM		1000​
Alice			Bob			Alice receive from Bob		200​
sarah			Nicolas			sarah receive from nicolas		300​
william			John			John send to william	1 000,00​
Olivier			maxime			Olivier send to maxime	500,00​
Maxime			Olivier			Maxime recieve from olivier		400​

 

[RudRud]

Book3
	A	B	C	D	E	F	G	H	I
1	Sender/Receiver	DATE	NOTE IMPORTANT	Receiver/Sender	NOT IMPORTANT	NOTE IMPORTANT2	DESCRIPTION	DEBIT	CREDIT
2	nicolas			sarah			nicolas send to sarah	300
3	John			William			John receive from WILLIAM		1000
4	Alice			Bob			Alice receive from Bob		200
5	sarah			Nicolas			sarah receive from nicolas		300
6	william			John			John send to william	1000
7	Olivier			maxime			Olivier send to maxime	500
8	Maxime			Olivier			Maxime receive from olivier		400
Sheet1

Hi @malkoriche, Kindly give a shot

Sub Malkoriche()
Dim Dict2 As Object
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Set Dict2 = CreateObject("scripting.dictionary")
dict.CompareMode = vbTextCompare
Dict2.CompareMode = vbTextCompare

a = Range("a2:i" & Cells(Rows.Count, "A").End(xlUp).Row).Value

For i = 1 To UBound(a, 1)
     If InStr(a(i, 7), "send") >= 1 Then
        debit = a(i, 8) 'Debit
        dict.Add a(i, 1), debit '
     ElseIf InStr(a(i, 7), "receive") >= 1 Then
          credit = a(i, 9) 'Credit
        Dict2.Add a(i, 4), credit
     End If
Next i

For Each ss In Range("a2:a" & Cells(Rows.Count, "A").End(xlUp).Row)

        'Debit Checker
        If dict.EXists(ss.Value) Then
                If dict(ss.Value) - Dict2(ss.Value) = 0 Then
                    ss.Offset(0, 7).Interior.Color = RGB(255, 235, 235)
                Else
                     ss.Offset(0, 7).Interior.Color = RGB(255, 192, 0) 'If false
                End If
        'Credit Checker
        ElseIf dict.EXists(ss.Offset(0, 3).Value) Then
                If dict(ss.Offset(0, 3).Value) - Dict2(ss.Offset(0, 3).Value) = 0 Then
                        ss.Offset(0, 8).Interior.Color = RGB(255, 235, 235)
                Else
                     ss.Offset(0, 8).Interior.Color = RGB(255, 192, 0) 'If false
                 End If
        Else
            ss.Offset(0, 8).Interior.Color = RGB(255, 192, 0) 'If false
        End If
        
Next ss

End Sub

 

[malkoriche]

Dear expert,

We encountered a runtime error 5 in the code you provided. The error is referring to the line If dict.Exists(ss.Value) Then. Our goal is to be able to select a range of data in an Excel document that contains debits and credits for a company and apply visual formatting to facilitate analysis. Here is a update version of your code:
Sub Malkoriche()
Dim Dict2 As Object
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Set Dict2 = CreateObject("scripting.dictionary")
dict.CompareMode = vbTextCompare
Dict2.CompareMode = vbTextCompare

a = Range("A2:I" & Cells(Rows.Count, "A").End(xlUp).Row).Value

For i = 1 To UBound(a, 1)
If InStr(a(i, 7), "send") >= 1 Then
debit = a(i, 8) 'Debit
dict.Add a(i, 1), debit '
ElseIf InStr(a(i, 7), "receive") >= 1 Then
credit = a(i, 9) 'Credit
Dict2.Add a(i, 4), credit
End If
Next i

For Each ss In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)

'Debit Checker
If dict.Exists(ss.Value) Then
If dict(ss.Value) - Dict2(ss.Value) = 0 Then
ss.Offset(0, 7).Interior.Color = RGB(255, 235, 235)
Else
ss.Offset(0, 7).Interior.Color = RGB(255, 192, 0) 'If false
End If
'Credit Checker
ElseIf dict.Exists(ss.Offset(0, 3).Value) Then
If dict(ss.Offset(0, 3).Value) - Dict2(ss.Offset(0, 3).Value) = 0 Then
ss.Offset(0, 8).Interior.Color = RGB(255, 235, 235)
Else
ss.Offset(0, 8).Interior.Color = RGB(255, 192, 0) 'If false
End If
Else
ss.Offset(0, 8).Interior.Color = RGB(255, 192, 0) 'If false
End If

Next ss

End Sub

 

[RudRud]

Hi, How about this?

Can you show more dataset instead? It will help us a lot

Book4
	A	B	C	D	E	F	G	H	I
1	Sender/Receiver	DATE	NOTE IMPORTANT	Receiver/Sender	NOT IMPORTANT	NOTE IMPORTANT2	DESCRIPTION	DEBIT	CREDIT
2	nicolas			sarah			nicolas send to sarah	300
3	John			William			John receive from WILLIAM		1000
4	Alice			Bob			Alice receive from Bob		200
5	sarah			Nicolas			sarah receive from nicolas		300
6	william			John			John send to william	1000
7	Olivier			maxime			Olivier send to maxime	500
8	Maxime			Olivier			Maxime receive from olivier		400
9	Maxime			Olivier			Maxime receive from olivier		300
10	william			John			John send to william	200
11	John			William			John receive from WILLIAM		200
Sheet1

Sub Malkoriche()
Dim Dict2 As Object
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Set Dict2 = CreateObject("scripting.dictionary")
dict.CompareMode = vbTextCompare
Dict2.CompareMode = vbTextCompare

[h2:i50000].Interior.Color = xlNone

a = Range("a2:i" & Cells(Rows.Count, "A").End(xlUp).Row).Value

For i = 1 To UBound(a, 1)
     If InStr(a(i, 7), "send") >= 1 Then
        If Not dict.exists(a(i, 1)) Then
            debit = a(i, 8) 'Debit
            dict.Add a(i, 1), debit '
        Else
             dict(a(i, 1)) = dict(a(i, 1)) + a(i, 8)
        End If
     ElseIf InStr(a(i, 7), "receive") >= 1 Then
        If Not Dict2.exists(a(i, 4)) Then
          credit = a(i, 9) 'Credit
        Dict2.Add a(i, 4), credit
          Else
            Dict2(a(i, 4)) = Dict2(a(i, 4)) + a(i, 9)
        End If
     End If
Next i

For Each ss In Range("a2:a" & Cells(Rows.Count, "A").End(xlUp).Row)

        'Debit Checker
        If dict.exists(ss.Value) Then
                If dict(ss.Value) - Dict2(ss.Value) = 0 Then
                    ss.Offset(0, 7).Interior.Color = RGB(255, 235, 235)
                Else
                     ss.Offset(0, 7).Interior.Color = RGB(255, 192, 0) 'If false
                End If
        'Credit Checker
        ElseIf dict.exists(ss.Offset(0, 3).Value) Then
                If dict(ss.Offset(0, 3).Value) - Dict2(ss.Offset(0, 3).Value) = 0 Then
                        ss.Offset(0, 8).Interior.Color = RGB(255, 235, 235)
                Else
                     ss.Offset(0, 8).Interior.Color = RGB(255, 192, 0) 'If false
                 End If
        Else
            ss.Offset(0, 8).Interior.Color = RGB(255, 192, 0) 'If false
        End If
       
Next ss

End Sub

 

[malkoriche]

I have implemented the changes you mentioned, and the code is now functioning correctly and producing the desired results.
However, I have realized that the description column contains unrelated information in many instances, making it unreliable for extracting the required data. After considering this issue, I suggest modifying the code to rely on matching the values in columns A, B (date), and D instead. The date needs to be the same month.
By matching these columns, we can ensure accurate comparisons and highlighting of the debit and credit amounts. Sorry if I do not provide the Excel data, it is because It is confidential.

best regards,
Malko

 

[RudRud]

1. The code currently only operates based on this month, which is 6; otherwise, nothing will happen.

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N
1	Sender/Receiver	DATE	NOTE IMPORTANT	Receiver/Sender	NOT IMPORTANT	NOTE IMPORTANT2	DESCRIPTION	DEBIT	CREDIT		Name	Debit	Credit	Diff
2	nicolas	6/21/2023		sarah			nicolas send to sarah	300			nicolas	300	300
3	John	6/22/2023		William			John receive from WILLIAM		1000		william	1200	1400	-200
4	Alice	6/23/2023		Bob			Alice receive from Bob		200		Olivier	500	500
5	sarah	6/24/2023		Nicolas			sarah receive from nicolas		300		Bob	0	200	-200
6	william	6/25/2023		John			John send to william	1000
7	Olivier	6/26/2023		maxime			Olivier send to maxime	500
8	Maxime	6/27/2023		Olivier			Maxime receive from olivier		400
9	Maxime	6/28/2023		Olivier			Maxime receive from olivier		100
10	william	6/29/2023		John			John send to william	200
11	John	6/30/2023		William			John receive from WILLIAM		200
12	Maxime	7/1/2023		Olivier			Maxime receive from olivier		100
13	John	6/30/2023		William			John receive from WILLIAM		200
Sheet1

Cell Formulas
Range	Formula
N2:N10	N2	=IF(L2-M2=0,"",L2-M2)

Sub Malkoriche()
Dim Dict2 As Object
Dim dict As Object
Dim mnth, i, debit, credit As Integer
Dim ss As Range
Dim a As Variant
Set dict = CreateObject("Scripting.Dictionary")
Set Dict2 = CreateObject("scripting.dictionary")
dict.CompareMode = vbTextCompare
Dict2.CompareMode = vbTextCompare

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

mnth = Month(Date) 'today month

[h2:i50000].Interior.Color = xlNone
[k2:m50000].Clear

a = Range("a2:i" & Cells(Rows.Count, "A").End(xlUp).Row).Value

For i = 1 To UBound(a, 1)
    If Month(a(i, 2)) = mnth Then
        If a(i, 8) > 1 Then
           If Not dict.exists(a(i, 1)) Then
               debit = a(i, 8) 'Debit
               dict.Add a(i, 1), debit '
           Else
                dict(a(i, 1)) = dict(a(i, 1)) + a(i, 8)
           End If
        ElseIf a(i, 9) > 1 Then
           If Not Dict2.exists(a(i, 4)) Then
             credit = a(i, 9) 'Credit
           Dict2.Add a(i, 4), credit
             Else
               Dict2(a(i, 4)) = Dict2(a(i, 4)) + a(i, 9)
           End If
        End If
    End If
Next i

For Each ss In Range("a2:a" & Cells(Rows.Count, "A").End(xlUp).Row)
    If Month(ss.Offset(0, 1).Value) = mnth Then
        'Debit Checker
        If dict.exists(ss.Value) Then
                If dict(ss.Value) - Dict2(ss.Value) = 0 Then
                    ss.Offset(0, 7).Interior.Color = RGB(255, 235, 235)
                Else
                     ss.Offset(0, 7).Interior.Color = RGB(255, 192, 0) 'If false
                End If
        'Credit Checker
        ElseIf dict.exists(ss.Offset(0, 3).Value) Then
                If dict(ss.Offset(0, 3).Value) - Dict2(ss.Offset(0, 3).Value) = 0 Then
                        ss.Offset(0, 8).Interior.Color = RGB(255, 235, 235)
                Else
                     ss.Offset(0, 8).Interior.Color = RGB(255, 192, 0) 'If false
                 End If
        Else
            ss.Offset(0, 8).Interior.Color = RGB(255, 192, 0) 'If false
        End If
     End If
Next ss

tt = Dict2.keys
For i = 0 To UBound(tt, 1)
        If dict.exists(tt(i)) Then
                dict(tt(i)) = Array(dict(tt(i)), Dict2(tt(i)))
        Else
            dict.Add tt(i), Array(0, Dict2(tt(i)))
        End If

Next i
t1 = dict.keys
t2 = dict.Items

[k2].Resize(UBound(t1, 1) + 1).Value = Application.Transpose(dict.keys)
[l2].Resize(UBound(t2, 1) + 1, 2).Value = Application.Transpose(Application.Transpose(dict.Items))

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

 

[malkoriche]

It's great! Thank you!