Script which can check if a debit has a corresponding credit [Solved/Closed]
dennisvhansen7
Posts Wednesday September 9, 2015Registration date
September 24, 2015
Last seen
-
Sep 9, 2015 at 07:44 AM - Latest reply: dennisvhansen7
Posts Wednesday September 9, 2015Registration date
September 24, 2015
Last seen
- Sep 24, 2015 at 02:30 AM
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.
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
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?
RayH122
Posts Tuesday August 31, 2010Registration dateContributorStatus
June 20, 2016
Last seen
>
dennisvhansen7
Posts Wednesday September 9, 2015Registration date
September 24, 2015
Last seen -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
dennisvhansen7
Posts Wednesday September 9, 2015Registration date
September 24, 2015
Last seen
>
RayH122
Posts Tuesday August 31, 2010Registration dateContributorStatus
June 20, 2016
Last seen -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.
RayH122
Posts Tuesday August 31, 2010Registration dateContributorStatus
June 20, 2016
Last seen
>
dennisvhansen7
Posts Wednesday September 9, 2015Registration date
September 24, 2015
Last seen -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
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.
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"
has helped 1683 users this month
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.
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!
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:
and
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 SubThis works perfectly now, thank you!