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