Answered by:
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 J13J12 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.
Answers

Hi AdrianEklund,
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 AdrianEklund Wednesday, March 8, 2017 2:22 PM

Hi AdrianEklund，
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 AdrianEklund Wednesday, March 8, 2017 2:21 PM
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?
Please describe your requirement exactly.
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.
Hope that can help you. 
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

Hi,AdrianEklund
I have understood your meaning.
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
Hope that can help you. 

Hi AdrianEklund,
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 AdrianEklund Wednesday, March 8, 2017 2:22 PM


Hi AdrianEklund，
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.

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?

Hi AdrianEklund，
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 AdrianEklund Wednesday, March 8, 2017 2:21 PM

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. "=I15J5", that's what causing your code to hang up Excel. Do you have any solution for that?