Iterate Columns using Solver and Goal Seek

[wdobson17]

Hello! I am trying to model the temperature differential of a pipeline across approximately 243km. To do this I've broken down the pipeline into different segments and the equations I'm using require guessing the equating the numbers to each other. I've been successful in getting all the different segments to converge and work independently, but if I chose to shorten the iterations I'm going to end up with a monstrous code. I'm relatively new to VBA and am trying to reach back to the couple classes I took in college to understand what I need to do. Below is my code as I've completed it so far, it works for the most part, but there's got to be a way to make it shorter. Hope anyone can help!

[VBA]Sub LCS2LIND()
Dim GSCOLE As Range
Dim fturb As Range

Set GSCOLE = Sheets("Summer").Range("B31:I31")
Set fturb = Sheets("Summer").Range("B29:I31")

'Segment 1
Static isWorking As Boolean

If Round(Range("J22").Value, 6) <> 1 And Not isWorking Then
isWorking = True
Range("B31").GoalSeek Goal:=1, ChangingCell:=Range("B29")
isWorking = False
End If

SolverAdd CellRef:="$B$4", Relation:=2, FormulaText:="$B$3"
SolverOk SetCell:="$B$4", MaxMinVal:=1, ValueOf:="0", ByChange:="$B$3"
SolverSolve

'Segment 2
If Round(Range("J22").Value, 6) <> 1 And Not isWorking Then
isWorking = True
Range("C31").GoalSeek Goal:=1, ChangingCell:=Range("C29")
isWorking = False
End If

SolverAdd CellRef:="$C$4", Relation:=2, FormulaText:="$C$3"
SolverOk SetCell:="$C$4", MaxMinVal:=1, ValueOf:="0", ByChange:="$C$3"
SolverSolve

'Segment 3
If Round(Range("J22").Value, 6) <> 1 And Not isWorking Then
isWorking = True
Range("D31").GoalSeek Goal:=1, ChangingCell:=Range("D29")
isWorking = False
End If

SolverAdd CellRef:="$D$4", Relation:=2, FormulaText:="$D$3"
SolverOk SetCell:="$D$4", MaxMinVal:=1, ValueOf:="0", ByChange:="$D$3"
SolverDelete CellRef:="$C$4", Relation:=2, FormulaText:="$C$3"
SolverSolve

'Segment 4
If Round(Range("J22").Value, 6) <> 1 And Not isWorking Then
isWorking = True
Range("E31").GoalSeek Goal:=1, ChangingCell:=Range("E29")
isWorking = False
End If

SolverAdd CellRef:="$E$4", Relation:=2, FormulaText:="$E$3"
SolverOk SetCell:="$E$4", MaxMinVal:=1, ValueOf:="0", ByChange:="$E$3"
SolverDelete CellRef:="$D$4", Relation:=2, FormulaText:="$D$3"
SolverSolve

'Segment 5
If Round(Range("J22").Value, 6) <> 1 And Not isWorking Then
isWorking = True
Range("F31").GoalSeek Goal:=1, ChangingCell:=Range("F29")
isWorking = False
End If

SolverAdd CellRef:="$F$4", Relation:=2, FormulaText:="$F$3"
SolverOk SetCell:="$F$4", MaxMinVal:=1, ValueOf:="0", ByChange:="$F$3"
SolverDelete CellRef:="$D$4", Relation:=2, FormulaText:="$D$3"
SolverSolve

'Segment 6
If Round(Range("J22").Value, 6) <> 1 And Not isWorking Then
isWorking = True
Range("G31").GoalSeek Goal:=1, ChangingCell:=Range("G29")
isWorking = False
End If

SolverAdd CellRef:="$G$4", Relation:=2, FormulaText:="$G$3"
SolverOk SetCell:="$G$4", MaxMinVal:=1, ValueOf:="0", ByChange:="$G$3"
SolverDelete CellRef:="$F$4", Relation:=2, FormulaText:="$F$3"
SolverSolve

'Segment 7
If Round(Range("J22").Value, 6) <> 1 And Not isWorking Then
isWorking = True
Range("H31").GoalSeek Goal:=1, ChangingCell:=Range("H29")
isWorking = False
End If

SolverAdd CellRef:="$H$4", Relation:=2, FormulaText:="$H$3"
SolverOk SetCell:="$H$4", MaxMinVal:=1, ValueOf:="0", ByChange:="$H$3"
SolverDelete CellRef:="$G$4", Relation:=2, FormulaText:="$G$3"
SolverSolve

'Segment 8
If Round(Range("J22").Value, 6) <> 1 And Not isWorking Then
isWorking = True
Range("I31").GoalSeek Goal:=1, ChangingCell:=Range("I29")
isWorking = False
End If

SolverAdd CellRef:="$I$4", Relation:=2, FormulaText:="$I$3"
SolverOk SetCell:="$I$4", MaxMinVal:=1, ValueOf:="0", ByChange:="$I$3"
SolverDelete CellRef:="$H$4", Relation:=2, FormulaText:="$H$3"
SolverSolve
End Sub[/VBA]

[Bob Phillips]

Try something like this

[VBA]Sub LCS2LIND()
Dim GSCOLE As Range
Dim fturb As Range
Dim col As String, col2 As String
Dim i As Long

Set GSCOLE = Sheets("Summer").Range("B31:I31")
Set fturb = Sheets("Summer").Range("B29:I31")

Static isWorking As Boolean

For i = 2 To 8 'B to I

If Round(Range("J22").Value, 6) <> 1 And Not isWorking Then
isWorking = True
Cells(31, i).GoalSeek Goal:=1, ChangingCell:=Cells(i, 29)
isWorking = False
End If

col = "$" & ColumnLetter(i) & "$"
SolverAdd CellRef:=col & "4", Relation:=2, FormulaText:=col & "3"
SolverOk SetCell:=col & "4", MaxMinVal:=1, ValueOf:="0", ByChange:=col & "3"
SolverSolve
col2 = "$" & ColumnLetter(i - 1) & "$"
If i > 2 Then SolverDelete CellRef:=col2 & "4", Relation:=2, FormulaText:=col2 & "3"
Next i

End Sub

'-----------------------------------------------------------------
Function ColumnLetter(col As Long)
'-----------------------------------------------------------------
Dim sColumn As String
On Error Resume Next
sColumn = Split(Columns(col).Address(, False), ":")(1)
On Error GoTo 0
ColumnLetter = sColumn
End Function
[/VBA]

[Teeroy]

Can't test this without you posting a sample workbook but this should be close.

[vba]Sub LCS2LIND_test()


Dim GSCOLE As Range
Dim fturb As Range
Dim i As Integer

Set GSCOLE = Sheets("Summer").Range("B31:I31")
Set fturb = Sheets("Summer").Range("B29:I31")

Static isWorking As Boolean

'Loop through 8 segments (expandable)

For i = 1 To 8

If Round(Range("J22").Value, 6) <> 1 And Not isWorking Then
SolverReset
isWorking = True
Cells(31, i + 1).GoalSeek Goal:=1, ChangingCell:=Cells(29, i + 1)
isWorking = False
Else
If i > 1 Then
SolverDelete CellRef:=Cells(4, i), Relation:=2, FormulaText:=Cells(3, i)
End If
End If

SolverAdd CellRef:=Cells(4, i + 2), Relation:=2, FormulaText:=Cells(3, i + 2)
SolverOk SetCell:=Cells(4, i + 2), MaxMinVal:=1, ValueOf:="0", ByChange:=Cells(3, i + 2)
SolverSolve

Next i

End Sub
[/vba]