Trying to perform an action, move one cell, and do it again

[msussman]

I am trying to get a macro to perform an action which finds the maximum value in one cell that translates to a minimum value in another cell. The macro works for a single cell (see code below), however, when I added in a for loop, it sets the first value to zero and then stops running.

The part I seem to be stuck on is offsetting the ChangeVal and Answer ranges by one cell and starting the whole thing over. My two biggest concerns are that the for loop is in the wrong place, or that the way i am trying to offset the cells is incorrect. If anyone has any ideas, I would really appreciate it.

Sub macro()

    Dim ChangeVal As Range, Answer As Range
    Dim j As Long
    Dim i As Double
    Dim xmax As Double

    'cell being modified
    Set ChangeVal = ActiveWorkbook.Sheets("ITC").Range("C341")
    Set Answer = ActiveWorkbook.Sheets("ITC").Range("C892")
    For  j = 1 to 3
    ChangeVal.Value = 0
     xmin = ChangeVal
     'cell being evaluated
     min_value = Answer
     y = Answer
     'increment
     i = 0.1
     'max x value
     xmax = Range("max").Value
     diff = (xmax - xmin) / 2
         Do While i <= diff
             xmin = xmin + diff
             ChangeVal = xmin
             Z = Answer
                 If Z > y Then
                     xmin = xmin - diff
                     xmax = xmin + diff
                     ChangeVal = xmin
                     y = Answer
                 Else
                     xmin = xmin - diff / 2
                     ChangeVal = xmin
                     y = Answer
                 End If
             diff = (xmax - xmin) / 2
         Loop
         ChangeVal = xmin
           Set ChangeVal = ChangeVal.Offset(0, 1)
           Set Answer = Answer.Offset(0, 1)
         Next j
    End Sub

 

[StephenCrump]

Welcome to the Forum!

As written, i.e. using .Offset(0,1) your code will loop three times and process:

ChangeVal = Sheets("ITC").Range("C341")
Answer = Sheets("ITC").Range("C892")

ChangeVal = Sheets("ITC").Range("D341")
Answer = Sheets("ITC").Range("D892")

ChangeVal = Sheets("ITC").Range("E341")
Answer = Sheets("ITC").Range("E892")

Is this what you wanted?

However, I have no idea what your code is meant to be doing, and I doubt it will give you the answers you want.
It seems to be simply moving ChangeVal closer to the value of Range("max"), taking no account of the value of Answer.

In each iteration of the loop:

- You set min_value = Answer but never use min_value
- You set Z = Answer and y = Answer several times in a Do Loop
- The value of Answer never changes

This means that Z will always equal y, and this bit of code, for example, will never execute:

If Z > y Then
    xmin = xmin - diff
    xmax = xmin + diff
    ChangeVal = xmin
    y = Answer
Else

What is the code actually meant to be doing?

 

[msussman]

What is the code actually meant to be doing?

The first thing it does is tests an input in the first cell ("ChangeVal") and after running through the workbook's calculations spits out a value into the output cell ("Answer"). The code then converges on the optimal answer. However, it only does it for one cell and I have 12 cells that are in the same row, but different columns that need to be optimized. The problem was the for loop, which was making the code go haywire.

I actually figured out a more accurate way to converge on the optimal answer and include the for loop. See the new code:

'Turns off screen updates, the status bar, and events to increase speed
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    
    'Variables used
    'offset iteration
    Dim j As Long
    'minimum increment for modifications
    Dim i As Double
    'max value for cell being modified
    Dim xmax As Double
    'starting value for cell being modified
    Dim xmin As Double
    'min value for cell being evaluated
    Dim min_value As Double
    'mid value for cell being evaluated
    Dim mid_value As Double
    'mid value used for assessing the slow at the midpoint
    Dim mid_value_2 As Double
    'max value for cell being evaluated
    Dim max_value As Double
    'Test value to determine if max value is the answer
    Dim test As Double
    'input cell
    Dim ChangeVal As Range
    'output cell
    Dim Answer As Range
    'message box
    Dim message As Integer

    'sets cells being modified to variable, sets initial value to 0
    
    Set ChangeVal = ActiveWorkbook.Sheets("Sheet1").Range("input_start")
    Set Answer = ActiveWorkbook.Sheets("Sheet1").Range("output_start")
     For j = 1 To 12

            'max x value
            xmax = Range("max").Value
            half_diff = (xmax - xmin) / 2
           
          'Test if max value is answer
            ChangeVal = xmax
            test = Answer
            
           If test = -xmax Then
          'do nothing
           Else
                      
            ChangeVal.Value = 0
     
            'cell being modified
            xmin = ChangeVal
            'Precision of calculation
            i = Range("precision") * 2
            
            'triangulates on the optimal answer
            Do While xmax - xmin > i
              
                'sets a minimum, maximum, and mid value to build initial triangle
                min_value = Answer
                ChangeVal = xmin + half_diff
                mid_value = Answer
                ChangeVal = xmax
                max_value = Answer
                
                'checks if the mid value gives an answer is the optimum and if it needs
                'to move closer to the max or min value
                If mid_value < min_value Then
                    If max_value < mid_value Then
                        xmin = xmin + half_diff
                    Else
                        'checks which direction the next iteration needs to go:
                            'a) toward the min
                            'b) toward the max
                        ChangeVal = xmin + half_diff + i
                        mid_value_2 = Answer
                        If mid_value_2 < mid_value Then
                            xmin = xmin + half_diff
                        Else
                            If xmin + half_diff + i >= xmax Then
                                Exit Do
                            Else
                            xmax = xmin + half_diff + i
                            End If
                        End If
                    End If
                Else
                'sets a new max value
                    xmax = xmin + half_diff
                End If
                'builds a new interval and sets the problem up again
                half_diff = (xmax - xmin) / 2
                ChangeVal = xmin
            Loop
            'pastes the optimal value into the cell
            ChangeVal = xmin + half_diff
            End If
           
         'shift input and output cell over by one column
           Set ChangeVal = ChangeVal.Offset(0, 1)
           Set Answer = Answer.Offset(0, 1)
         
         'repeat optimization for next month
         Next j
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    message = MsgBox("ITC Optimization Complete!", vbOKOnly, "ITC Optimizer")

This code tests the maximum possible input, and if it works, then the cell offsets, then it triangulates on the right answer.

 

[StephenCrump]

However, I have no idea what your code is meant to be doing, and I doubt it will give you the answers you want.
It seems to be simply moving ChangeVal closer to the value of Range("max"), taking no account of the value of Answer.

Oops, my mistake, sorry! I read your code too quickly thinking Answer was a static value, whereas really you are setting:

y = Answer.Value where Answer is a cell presumably changing value on each iteration.

I actually figured out a more accurate way to converge on the optimal answer and include the for loop.

I am just curious. Did you consider using Goal Seek or Solver in VBA?

 

[msussman]

Oops, my mistake, sorry! I read your code too quickly thinking Answer was a static value, whereas really you are setting:

y = Answer.Value where Answer is a cell presumably changing value on each iteration.



I am just curious. Did you consider using Goal Seek or Solver in VBA?

Goal seek doesn't work because I need to add constraints, and this was meant to circumvent solver. The algorithms in this model are complex and require an evolutionary solver but it takes 3 hours to converge on the right answer. This does it in 15 minutes.