Sub MultiSolve()
Dim rTgt As Range
Dim rVal As Range
Dim rChg As Range
Dim rBad As Range
Dim i As Long
Do
Set rTgt = Application.InputBox(Title:="Select a range in a single row or column", _
Prompt:="Select your range which contains the ""Set Cell"" range", _
Default:="C11:E11", _
Type:=8)
Set rTgt = Intersect(rTgt, rTgt.Worksheet.UsedRange)
Set rVal = Application.InputBox(Title:="Select a range in a single row or column", _
Prompt:="Select the range which the ""Set Cells"" will be changed to", _
Default:="C12:E12", _
Type:=8)
Set rVal = Intersect(rVal, rVal.Worksheet.UsedRange)
Set rChg = Application.InputBox(Title:="Select a range in a single row or column", _
Prompt:="Select the range of cells that will be changed", _
Default:="G8:G10", _
Type:=8)
Set rChg = Intersect(rChg, rChg.Worksheet.UsedRange)
If rTgt.Cells.Count = rVal.Cells.Count And _
rTgt.Cells.Count = rChg.Cells.Count Then Exit Do
If MsgBox(Prompt:="Ranges were different lengths, please press yes to re-enter, no to quit", _
Buttons:=vbYesNo + vbCritical) = vbNo Then Exit Sub
Loop
On Error Resume Next
Set rBad = rChg.SpecialCells(xlCellTypeFormulas)
If Not rBad Is Nothing Then
rBad.Select
MsgBox "No formulas allowed in changing cells!"
Exit Sub
End If
Set rBad = rBad.SpecialCells(xlCellTypeBlanks)
If Not rBad Is Nothing Then
rBad.Select
MsgBox "No blanks allowed in changing cells!"
Exit Sub
End If
On Error GoTo 0
For i = 1 To rTgt.Rows.Count
SolverReset
SolverOk setcell:=rTgt(i).Address, _
MaxMinVal:=3, _
ValueOf:=rVal(i).Value, _
ByChange:=rChg(i).Address
SolverAdd CellRef:=rChg(i).Address, _
Relation:=3, _
FormulaText:=0
SolverSolve UserFinish:=True
Next i
End Sub