Previous Topic Next Topic

Script which can check if a debit has a corresponding credit

Solved/Closed
dennisvhansen
Posts
7
Registration date
Wednesday September 9, 2015
Status
Member
Last seen
September 24, 2015
 - Sep 9, 2015 at 07:44 AM
dennisvhansen
Posts
7
Registration date
Wednesday September 9, 2015
Status
Member
Last seen
September 24, 2015
 - Sep 24, 2015 at 02:30 AM
Hello,

I am new to VBA, and I am searching for a script which can check if a debit has a corresponding credit (same value bue with -/+), and highlight the cells in green. Cells that doesn't have a corresponding cell needs to be highlighted in red. I want to check from cell B2 to L56, as there are several subsidiarys I need to match.

I have been looking everywhere for this, but with no luck so far.

I hope you are able to help.

Regards,

Dennis
Related:

3 replies

Answer 1 / 3
RayH
Sep 16, 2015 at 08:35 PM
Using the file you posted.
I skipped the zero values, as these would all match each other.
You can change the ranges to suite. 


Sub finddupes()
dim found as Boolean

For Each mycell In Worksheets("Ark1").Range("B2:L34")
myvalue = Abs(mycell.Value)
If myvalue <> 0 Then
found = False
    For Each chkcell In Worksheets("Ark1").Range("B2:L34")
        If mycell <> chkcell Then
            If myvalue = Abs(chkcell.Value) Then
                chkcell.Interior.ColorIndex = 4 ' Green
                mycell.Interior.ColorIndex = 4
                found = True
            End If
        End If
    Next
If found = False Then mycell.Interior.ColorIndex = 3 'Red
End If
Next

End Sub
1
dennisvhansen
Posts
7
Registration date
Wednesday September 9, 2015
Status
Member
Last seen
September 24, 2015
Sep 17, 2015 at 03:14 AM
This is just perfect! Exactly what I have been looking for, you have saved me for several hours of work :) Highly appreciated!
0
dennisvhansen
Posts
7
Registration date
Wednesday September 9, 2015
Status
Member
Last seen
September 24, 2015
Sep 17, 2015 at 03:16 AM
A comment though... Would it be possible to add another color, say yellow... For Numbers that are within, say 100, of each other? So I know that it is only a minor difference?
0
RayH
Posts
122
Registration date
Tuesday August 31, 2010
Status
Contributor
Last seen
June 20, 2016
 25 > dennisvhansen
Posts
7
Registration date
Wednesday September 9, 2015
Status
Member
Last seen
September 24, 2015
Sep 17, 2015 at 12:24 PM
Here's an updated version that includes the check for minor difference.
I have added comments to explain what is going on and made important values variables so they only need to be set once. This makes it easier to modify for changes. 


Sub finddupes()
Dim found As Boolean
Dim diff As Long
Dim myrng As Range
Dim highvalue As Long

Application.ScreenUpdating = False  ' Turn off screen updates to speed up the routine

Set myrng = Worksheets("Ark1").Range("B2:L34")  ' set the range of the data being checked
highvalue = 100     ' set the value of the difference

myrng.Interior.ColorIndex = 0       'clear background of cell in range

For Each mycell In myrng
myValue = Abs(mycell.Value) ' get the absolute value of the source cell
If myValue <> 0 Then    ' is the value being match zero? No? Carry on doing the match
found = False   ' cleat the found a match flag

    For Each chkcell In myrng
        If mycell <> chkcell Then 'not the same cell, carry on...
            mychkValue = Abs(chkcell.Value) 'get the absolute value of the target cell
            If mychkValue <> 0 Then  ' target cell value not zero
                diff = Abs(myValue - mychkValue) ' calc difference between the source and target cells
                
                If diff > 0 And diff < highvalue Then ' is the difference between 0 and 100, Yes? Set to Yellow
                    chkcell.Interior.ColorIndex = 6 ' Yellow
                    mycell.Interior.ColorIndex = 6
                    found = True    ' set the flag to say we found a match
                ElseIf myValue = mychkValue Then    ' otherwise must be equal, so set to Green
                    chkcell.Interior.ColorIndex = 4 ' Green
                    mycell.Interior.ColorIndex = 4
                    found = True    ' set the flag to say we found a match
                End If
                
            End If
        End If
    Next
If found = False Then mycell.Interior.ColorIndex = 3 'did we find a match? No? Then set to Red
End If
Next

Application.ScreenUpdating = True   ' Turn screen updates back on

End Sub

0
dennisvhansen
Posts
7
Registration date
Wednesday September 9, 2015
Status
Member
Last seen
September 24, 2015
 > RayH
Posts
122
Registration date
Tuesday August 31, 2010
Status
Contributor
Last seen
June 20, 2016
Sep 23, 2015 at 02:54 AM
Hello RayH and thank you for all your help. This is exactly what I am looking for, but there seems to be some minor issue with it. If I have 2 cells with the following values: 213.154,33
and -213.154,33333 the cells both turn red, where it should turn yellow.
It would be prefered though if 2 cells are equal before the decimals, that they turn green, but if not they should atleast go yellow, so I can check them afterwards.

Sorry for the inconvinience!
0
RayH
Posts
122
Registration date
Tuesday August 31, 2010
Status
Contributor
Last seen
June 20, 2016
 25 > dennisvhansen
Posts
7
Registration date
Wednesday September 9, 2015
Status
Member
Last seen
September 24, 2015
Sep 23, 2015 at 11:22 AM
I found a couple of issues (bugs) that I have now corrected.
1. diff is now a Double variable type.
2.The comparison of the cell location was being done incorrectly.

If you want to ignore the decimal places then using these in place of the originals will do that for you: 
myvalue = Int(Abs(mycell.Value)) ' get the absolute value of the source cell

and 
mychkvalue = Int(Abs(chkcell.Value)) 'get the absolute value of the target cell



Sub finddupes()
Dim found As Boolean
Dim diff As Double
Dim myrng As Range
Dim highvalue As Long
Dim myvalue As Double
Dim mychkvalue As Double

Application.ScreenUpdating = False  ' Turn off screen updates to speed up the routine

Set myrng = Worksheets("Ark1").Range("B2:L34")  ' set the range of the data being checked
highvalue = 100   ' set the value of the difference

myrng.Interior.ColorIndex = 0       'clear background of cell in range

For Each mycell In myrng
myvalue = Abs(mycell.Value) ' get the absolute value of the source cell
If myvalue <> 0 Then    ' is the value being match zero? No? Carry on doing the match
found = False   ' clear the found a match flag
    For Each chkcell In myrng
        If mycell.Address <> chkcell.Address Then 'not the same cell, carry on...

            mychkvalue = Abs(chkcell.Value) 'get the absolute value of the target cell
            If mychkvalue <> 0 Then  ' target cell value not zero
                diff = Abs(myvalue - mychkvalue) ' calc difference between the source and target cells
                
                If diff > 0 And diff < highvalue Then ' is the difference between 0 and highvalue, Yes? Set to Yellow
                    chkcell.Interior.ColorIndex = 6 ' Yellow
                    mycell.Interior.ColorIndex = 6
                    found = True    ' set the flag to say we found a match
                ElseIf myvalue = mychkvalue Then    ' otherwise must be equal, so set to Green
                    chkcell.Interior.ColorIndex = 4 ' Green
                    mycell.Interior.ColorIndex = 4
                    found = True    ' set the flag to say we found a match
                End If
                
            End If
        End If
    Next
If found = False Then mycell.Interior.ColorIndex = 3 'did we find a match? No? Then set to Red
End If
Next

Application.ScreenUpdating = True   ' Turn screen updates back on

End Sub
0
Answer 2 / 3
venkat1926
Posts
1864
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
August 7, 2021
 805
Sep 10, 2015 at 04:16 AM
please post a very small extract of your sheet
0
dennisvhansen
Posts
7
Registration date
Wednesday September 9, 2015
Status
Member
Last seen
September 24, 2015
Sep 10, 2015 at 06:30 AM
http://postimg.org/image/40hbtw8eb/

Here is the small extract of what you requested... I have started doing some of it manually, and as you can see I have put 2 rings around 2 cells that have an exact match (debit/credit)... The ones that are red, are ones where it doesn't have a match. As the numbers are large, I don't think it will ever occur that more than 2 cells have the same value.

I hope this makes sense.
0
Answer 3 / 3
venkat1926
Posts
1864
Registration date
Sunday June 14, 2009
Status
Contributor
Last seen
August 7, 2021
 805
Sep 11, 2015 at 01:35 AM
this is image. I cannot transfer data to my excel file. besides there should be column headings. It looks any data in any column may correspond with data in any other column, are you familiar with macro?

suggest save a sample file and send it(as an attchment) through "speedyshare.com"
0
dennisvhansen
Posts
7
Registration date
Wednesday September 9, 2015
Status
Member
Last seen
September 24, 2015
Sep 16, 2015 at 02:45 AM
Sorry for the late reply, I have not been in the office since thursday.

I've uploaded it now.
There are column headings in the uploaded document.

https://authentification.site/P8SWD/Small-extract.xlsx

I am afraid, I am not too familiar with macros.
0