T
transferxxx
Could anybody pls correct first part of macro macro below (problem
with defining the range- as i tried to modify an existing macro) -
Thxs
Sub Multi_Goal_SeekRANGE()
Dim TargetVal As Range, DesiredVal As Range, ChangeVal As Range,
CVcheck As Range
Dim CheckLen As Long, i As Long
Let rgt = (Range("Column").Value)
Let Frz = 13 - (Range("Column").Value)
ActiveWorkbook.PrecisionAsDisplayed = False
Let Change = Range("Changedto").Offset(0, rgt).Resize(1, Frz)
Let Setc = Range("Setcell").Offset(0, rgt).Resize(1, Frz)
Let Bychg = Range("ByChanging").Offset(0, rgt).Resize(1, Frz)
restart:
With Application
Set TargetVal = Setc.Address
Set DesiredVal = Change.Address
Set ChangeVal = Bychg.Address
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
with defining the range- as i tried to modify an existing macro) -
Thxs
Sub Multi_Goal_SeekRANGE()
Dim TargetVal As Range, DesiredVal As Range, ChangeVal As Range,
CVcheck As Range
Dim CheckLen As Long, i As Long
Let rgt = (Range("Column").Value)
Let Frz = 13 - (Range("Column").Value)
ActiveWorkbook.PrecisionAsDisplayed = False
Let Change = Range("Changedto").Offset(0, rgt).Resize(1, Frz)
Let Setc = Range("Setcell").Offset(0, rgt).Resize(1, Frz)
Let Bychg = Range("ByChanging").Offset(0, rgt).Resize(1, Frz)
restart:
With Application
Set TargetVal = Setc.Address
Set DesiredVal = Change.Address
Set ChangeVal = Bychg.Address
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