none
Macro for correcting a table so the difference between closest cells not exceed 4. RRS feed

  • Question

  • Question
    You cannot vote on your own post
    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

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
    Monday, February 27, 2017 10:19 AM
  • 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
    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?
    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.
    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
  • 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.
    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
  • 
    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
    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
  • 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.

    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
  • 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
    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