Multi_Goal_Seek() VBA

[alan.sluder]

in using the following vba code below: this will work when i chose a one dimensional problem ie i want the value in cell BA7 to equal that in cell V7 by using goal seek to change the valve X7. Not seeing why i can't change values in column BA to equal those in column V by changing column X. in both examples the cells or columns are being picked by mousing over and selecting either the cells or columns.

Sub Multi_Goal_Seek()
Dim TargetVal As Range, DesiredVal As Range, ChangeVal As Range, CVcheck As Range
Dim CheckLen As Long, i As Long

restart:
With Application
Set TargetVal = .InputBox(Title:="Select a range in a single row or column", _
prompt:="Select your range which contains the ""Set Cell"" range", Default:=Range("C11:E11").Address, Type:=8)
'no default option
'prompt:="Select your range which contains the ""Set Cell"" range",, Type:=8)
Set DesiredVal = .InputBox(Title:="Select a range in a single row or column", _
prompt:="Select the range which the ""Set Cells"" will be changed to", Default:=Range("C12:E12").Address, Type:=8)
'no default option
'prompt:="Select the range which the ""Set Cells"" will be changed to",, Type:=8)
Set ChangeVal = .InputBox(Title:="Select a range in a single row or column", _
prompt:="Select the range of cells that will be changed", Default:=Range("G8:G10").Address, Type:=8)
'no default option
'prompt:="Select the range of cells that will be changed",, Type:=8)
End With

'Ensure that the changing cell range contains only values, no formulas allowed
Set CVcheck = Intersect(ChangeVal, Union(Sheets(ChangeVal.Parent.Name).Cells.SpecialCells(xlBlanks), Sheets(ChangeVal.Parent.Name).Cells.SpecialCells(xlConstants)))
If CVcheck Is Nothing Then
MsgBox "Changing value range contains no blank cells or values" & vbNewLine & _
"Goal seek only works if the cells to be changed are values, please ensure that this is the case", vbCritical
Application.GoTo reference:=DesiredVal
Exit Sub
Else

If CVcheck.Cells.Count <> DesiredVal.Cells.Count Then
MsgBox "Changing value range contains formulas" & vbNewLine & _
"Goal seek only works if the cells to be changed are values, please ensure that this is the case", vbCritical
Application.GoTo reference:=DesiredVal
Exit Sub
End If
End If

'Ensure that the amount of cells is consistent
If TargetVal.Cells.Count <> DesiredVal.Cells.Count Or TargetVal.Cells.Count <> ChangeVal.Cells.Count Then
CheckLen = MsgBox("Ranges were different lengths, please press yes to re-enter", vbYesNo + vbCritical)
If CheckLen = vbYes Then
'If ranges are different sizes and user wants to redo then restart code
GoTo restart
Else
Exit Sub
End If
End If

' Loop through the goalseek method
For i = 1 To TargetVal.Columns.Count
TargetVal.Cells(i).GoalSeek Goal:=DesiredVal.Cells(i).Value, ChangingCell:=ChangeVal.Cells(i)
Next i
End Sub

 

[StephenCrump]

If you're always working with column vectors, then try making this one change to your code:

For i = 1 To TargetVal.[B][COLOR=#ff0000]Rows[/COLOR][/B].Count
    TargetVal.Cells(i).GoalSeek Goal:=DesiredVal.Cells(i).Value, ChangingCell:=ChangeVal.Cells(i)
Next i