Vertical Multiple Goal Seek
 

Can someone correct the macro below to make it work when the data are
aligned vertically instead of horizontal (presently only 1st cell is
getting right goal seek value - other cells below are not properly
updated)

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", 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 - TO VALUE", 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 - BY
CHANGING", 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(xlBlank s), Sheets
(ChangeVal.Parent.Name).Cells.SpecialCells(xlConst ants)))
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