# Macro for correcting a table so the difference between closest cells not exceed 4.

• ### Question

• 0

I need help with writing a macro doing this:

If the differece between nearest cells is more then 4;

Do this; move the exceeding sum of the difference to previous cell, and keep doing that til there is no higher difference than 4 between any closest cells. It's important that the total sum of the cells should be as it was before running the macro. So think of the column like a circle, J30 is next to J7, see example.

The expected column will look something like the example below, with highest values in the middle and lower values in the start and at the end.

Example:

J7 - 9
J8 - 8
J9 - 7 - OK (for now but will probably change, see below).
J10- 6 - OK (for now but will probably change, see below).
J11- 8
J12 - 11
J13 - 17 - Here's the difference between J12 and J13 = 6. Then 1 should me moved from J13 to J12.
J14 - 22 - Now cause J13 moved 1 to J12, there's 16 in J13 and the difference to J14 is = 6. Move 1 from J14 to J13. I don't know what your solution is but as you can see the difference between J13-J12 will be 6 again, so the loop will have to run several times.
J15 - 22
J16 - 22
J17 - 22
J18 - 22
J19 - 22
J20 - 22
J21 - 22
J22 - 22
J23 - 22
J24 - 22
J25 - 22
J26 - 22
J27 - 22
J28 - 15
J29 - 7
J30 - 1 - I suspect we only can take value from one way, either from down to up or from up to down, and as in the example above, we are taking it from down to up. So J30 will take from J7 so the difference to J29 not exceed 4.

Hope this example explains what I want to do.

Tuesday, February 14, 2017 6:48 PM

• ﻿
Here is all my code.
```Sub cal()
Dim I, count As Integer
Dim rng As Range
Dim cel As Range
Dim flag As Boolean
flag = True
Set rng = ActiveSheet.Range("a1", "a24")
count = rng.Cells.count
Do While flag
flag = False
For I = 1 To count
Set cel1 = ActiveSheet.Cells(I, 1)
If I = count - 1 Then
Set cel2 = ActiveSheet.Cells(count, 1)
Set cel3 = ActiveSheet.Cells(1, 1)
ElseIf I = count Then
Set cel2 = ActiveSheet.Cells(1, 1)
Set cel3 = ActiveSheet.Cells(2, 1)
Else
Set cel2 = ActiveSheet.Cells(I + 1, 1)
Set cel3 = ActiveSheet.Cells(I + 2, 1)
End If
If change(rng, I, cel1, cel2, cel3) Then
flag = True
End If
Next I
Loop
End Sub
Function change(ByVal rng As Range, ByVal index As Integer, ByVal cel1 As Range, ByVal cel2 As Range, ByVal cel3 As Range)
Dim dif, esum As Integer
dif = cel1 - cel2
If dif > 4 Then
cel2 = cel2 + (dif - 4)
GetNumFromDownToUp rng, index + 2, (dif - 4)
change = True
ElseIf dif < -4 Then
esum = Int((Abs(dif) - 4) / 2) + (Abs(dif - 4) Mod 2)
cel1 = cel1 + esum
cel2 = cel2 - esum
change = True
Else
change = False
End If
End Function
Function GetNumFromDownToUp(ByVal rng As Range, ByVal index As Integer, ByVal sum As Integer)
If index = rng.Cells.count + 1 Then
index = 1
ElseIf index = rng.Cells.count + 2 Then
index = 2
End If
If sum - rng.Cells(index, 1) > 0 Then
sum = sum - rng.Cells(index, 1)
rng.Cells(index, 1) = 0
index = index + 1
If index > rng.Cells.count Then
index = 1
End If
GetNumFromDownToUp rng, index, sum
Else
rng.Cells(index, 1) = rng.Cells(index, 1) - sum
End If
End Function```

ShootScreen

• Marked as answer by Wednesday, March 8, 2017 2:22 PM
Monday, February 27, 2017 10:19 AM

You could modify cal() method like this

```Sub cal()
Dim I, count As Integer
Dim rng As Range
Dim cel As Range
Dim flag As Boolean
flag = True
Set rng = ActiveSheet.Range("J7", "J30")
count = rng.Cells.count
Do While flag
flag = False
For I = 1 To count
Set cel1 = rng.Cells(I, 1)
If I = count - 1 Then
Set cel2 = rng.Cells(count, 1)
Set cel3 = rng.Cells(1, 1)
ElseIf I = count Then
Set cel2 = rng.Cells(1, 1)
Set cel3 = rng.Cells(2, 1)
Else
Set cel2 = rng.Cells(I + 1, 1)
Set cel3 = rng.Cells(I + 2, 1)
End If
If change(rng, I, cel1, cel2, cel3) Then
flag = True
End If
Next I
Loop
End Sub```
Best regards,
Terry

• Marked as answer by Wednesday, March 8, 2017 2:21 PM
Tuesday, March 7, 2017 9:05 AM

### All replies

• Hi,
>>move the exceeding sum of the difference to previous cell
According to your description,I thought exceeding sum of the difference is the sum of the differnece minus 4.
However,you divide the sum of the differnece minus 4 equally.
In your example,after first loop values become J12=12 J13=17 J14=21,
what will values change when going to next loop?
Here is my code.
```Sub cal()
Dim i, count As Integer
Dim rng As Range
Dim cel As Range
Dim flag As Boolean
flag = True
Set rng = ActiveSheet.Range("a1", "a11")
count = rng.Cells.count
Do While flag
flag = False
For i = 2 To count
Set cel1 = ActiveSheet.Cells(i - 1, 1)
Set cel2 = ActiveSheet.Cells(i, 1)
If change(cel1, cel2) Then
flag = True
End If
Next i
Loop
End Sub
Function change(ByVal cel1 As Range, ByVal cel2 As Range)
Dim dif, esum As Integer
dif = cel1 - cel2
esum = Int((Abs(dif) - 4)/2)
If dif > 4 Then
cel1 = cel1 - esum
cel2 = cel2 + esum
change = True
ElseIf dif < -4 Then
cel1 = cel1 + esum
cel2 = cel2 - esum
change = True
Else
change = False
End If
End Function```
You can replace "esum = Int((Abs(dif) - 4)/2)" with your own meaning of exceeding sum.
Wednesday, February 15, 2017 8:41 AM
• Hi Terry X,

Nothing happens when I run your macro code.

Sorry if my description is bad, english is not my first language.

What I mean is that if the difference between closest cells are more then 4, correct it till 4, but the total sum of all cells shall still be the same.

I've made a document to show how I think the macro should run, but I'm very open for other methods, the goal is that the "jump" from one cell to another can't be more then 4.

http://www.mediafire.com/file/uyx8y1n0f4ip30s/Macro_run.xlsx

Thursday, February 16, 2017 10:31 PM
I think the key point is how to minus value when we take value from
down to top.
Recursive algorithm maybe efficient to do this.
```Sub GetNumFromDownToUp(ByVal rng As Range, ByVal index As Integer, ByVal sum As Integer)
If sum - rng.Cells(index, 1) > 0 Then
sum = sum - rng.Cells(index, 1)
rng.Cells(index, 1) = 0
index = index + 1
GetNumFromDownToUp rng, index, sum
Else
rng.Cells(index, 1) = rng.Cells(index, 1) - sum
End If
End Sub```

Monday, February 20, 2017 1:09 AM
• When I paste your code to the modul, it doesn't show up as a available macro in the macro window. Something has to be wrong with the code?
Wednesday, February 22, 2017 10:49 AM
• ﻿
Here is all my code.
```Sub cal()
Dim I, count As Integer
Dim rng As Range
Dim cel As Range
Dim flag As Boolean
flag = True
Set rng = ActiveSheet.Range("a1", "a24")
count = rng.Cells.count
Do While flag
flag = False
For I = 1 To count
Set cel1 = ActiveSheet.Cells(I, 1)
If I = count - 1 Then
Set cel2 = ActiveSheet.Cells(count, 1)
Set cel3 = ActiveSheet.Cells(1, 1)
ElseIf I = count Then
Set cel2 = ActiveSheet.Cells(1, 1)
Set cel3 = ActiveSheet.Cells(2, 1)
Else
Set cel2 = ActiveSheet.Cells(I + 1, 1)
Set cel3 = ActiveSheet.Cells(I + 2, 1)
End If
If change(rng, I, cel1, cel2, cel3) Then
flag = True
End If
Next I
Loop
End Sub
Function change(ByVal rng As Range, ByVal index As Integer, ByVal cel1 As Range, ByVal cel2 As Range, ByVal cel3 As Range)
Dim dif, esum As Integer
dif = cel1 - cel2
If dif > 4 Then
cel2 = cel2 + (dif - 4)
GetNumFromDownToUp rng, index + 2, (dif - 4)
change = True
ElseIf dif < -4 Then
esum = Int((Abs(dif) - 4) / 2) + (Abs(dif - 4) Mod 2)
cel1 = cel1 + esum
cel2 = cel2 - esum
change = True
Else
change = False
End If
End Function
Function GetNumFromDownToUp(ByVal rng As Range, ByVal index As Integer, ByVal sum As Integer)
If index = rng.Cells.count + 1 Then
index = 1
ElseIf index = rng.Cells.count + 2 Then
index = 2
End If
If sum - rng.Cells(index, 1) > 0 Then
sum = sum - rng.Cells(index, 1)
rng.Cells(index, 1) = 0
index = index + 1
If index > rng.Cells.count Then
index = 1
End If
GetNumFromDownToUp rng, index, sum
Else
rng.Cells(index, 1) = rng.Cells(index, 1) - sum
End If
End Function```

ShootScreen

• Marked as answer by Wednesday, March 8, 2017 2:22 PM
Monday, February 27, 2017 10:19 AM
• This looks very promising!

But when I run your code, Microsoft Excel stops responding/working when the numbers are:

10

6

2

2

5

11

16

20

22

22

22

22

22

22

22

22

22

22

22

22

22

22

18

14

Monday, February 27, 2017 11:01 PM

I have tested the code again and it still works for me .

According to your issue,i suggest you create a new workbook file to test the code and make sure data in cells from A1 to A24 same with me.

If possible,please tell me how do you test the code and show me the data before and after you run the code so I could make a more detailed analysis.

Tuesday, February 28, 2017 7:59 AM
• Yeah it's working when I run it in a new workbook file. I've uploaded my file in link below. Maybe you can help me with making the code work in cells J7:J30 in sheet Data?

http://www.mediafire.com/file/1zu8f3d5jhy872f/abb.xlsm

Monday, March 6, 2017 11:00 AM

You could modify cal() method like this

```Sub cal()
Dim I, count As Integer
Dim rng As Range
Dim cel As Range
Dim flag As Boolean
flag = True
Set rng = ActiveSheet.Range("J7", "J30")
count = rng.Cells.count
Do While flag
flag = False
For I = 1 To count
Set cel1 = rng.Cells(I, 1)
If I = count - 1 Then
Set cel2 = rng.Cells(count, 1)
Set cel3 = rng.Cells(1, 1)
ElseIf I = count Then
Set cel2 = rng.Cells(1, 1)
Set cel3 = rng.Cells(2, 1)
Else
Set cel2 = rng.Cells(I + 1, 1)
Set cel3 = rng.Cells(I + 2, 1)
End If
If change(rng, I, cel1, cel2, cel3) Then
flag = True
End If
Next I
Loop
End Sub```
Best regards,
Terry

• Marked as answer by Wednesday, March 8, 2017 2:21 PM
Tuesday, March 7, 2017 9:05 AM
• It's working! Thank you!

I still have a problem with Microsoft Excel stops responding/working when I run your code - but I know why:

The cells need to have a fixed value, and not to be an answer to ex. "=I15-J5", that's what causing your code to hang up Excel. Do you have any solution for that?

Wednesday, March 8, 2017 2:20 PM