Goal seek using macro

[promise899]

I have transposed a formula that has the same variable on both sides of the equation, thus producing two separate equations that equal each other.

For the first iteration, I find f value using goal seek tool.

each iteration(2,3,4,5) I want to use goal seek tools in order to find f values. After finding f value I can find Cchezy and Vnew because it depends on f value as can be seen from excel sheet.

Iteration continues until V and Vnew value be equal. I think to use assing macro to button in order to use goal seek tool each times . But I cant find how to do it? Thank you.

soru1.xlsx
	A	B	C	D	E	F
1		0.015974	<<--Value of f		d=	0.50m
2					b=	10.00m
3	L.H.S	R.H.S	L.H.S-R.H.S		J=	0.002
4	7.912035	7.911641	0.000394221		ks=	0.01mm
5
6					θ=	0.002
7					V=	0.10
8					DH=	1.818182
9					Re=	181818.2
10
11
12	Iteration	V(m/s)	f	Cchezy	Vnew(m/s)
13	1	0.1	0.016	70.09188	0.279196552
14	2	0.279197
15	3
16	4
17	5
Sayfa1

Cell Formulas
Range	Formula
A4	A4	=1/SQRT(B1)
B4	B4	=-2*LOG10((F4*0.001/3.71/F8)+(2.51)/F9/SQRT(B1))
C4	C4	=A4-B4
F8	F8	=4*(F1*F2)/(2*F1+F2)
F9	F9	=(1000*F7*F8)/0.001
C13	C13	=B1
D13	D13	=SQRT(8*9.81/B1)
E13	E13	=D13*SQRT(0.25*F8*SIN(RADIANS(F6)))
B14	B14	=E13

 

[promise899]

I cant edit first message but I need to indicate that for each Vnew value, Re and R.H.S values also be changed.

 

[promise899]

up

 

[BSALV]

i don't know what you do after an iteration, but this can give you an idea

Sub Promise()
     For i = 1 To 4                                             ' 4 iterations
          Range("C4").GoalSeek Goal:=0, ChangingCell:=Range("B1")     'your goalseek
          With Range("B13:E13")                                 'the wanted results are in B13:E13
               .Offset(i).Value = .Value                        'copy them hardcoded to the 4 next lines
          End With
          MsgBox "now do something before the next iteration", vbInformation
     Next
End Sub

 

[promise899]

i don't know what you do after an iteration, but this can give you an idea

Sub Promise()
     For i = 1 To 4                                             ' 4 iterations
          Range("C4").GoalSeek Goal:=0, ChangingCell:=Range("B1")     'your goalseek
          With Range("B13:E13")                                 'the wanted results are in B13:E13
               .Offset(i).Value = .Value                        'copy them hardcoded to the 4 next lines
          End With
          MsgBox "now do something before the next iteration", vbInformation
     Next
End Sub

Your code is well but for each iteration V values should be changed. but in your codes it is constant for each step.

For clarify I uploaded video about which I am trying to do.

Watch goalseek | Streamable

Watch "goalseek" on Streamable.

streamable.com

 

[promise899]

Your code is well but for each iteration V values should be changed. but in your codes it is constant for each step.

For clarify I uploaded video about which I am trying to do.

Watch goalseek | Streamable

Watch "goalseek" on Streamable.

streamable.com

soru1.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L	M
1		0.012965	<<--Value of f		d=	0.50m
2					b=	10.00m
3	L.H.S	R.H.S	L.H.S-R.H.S		J=	0.002
4	8.78225	8.782291	-4.17921E-05		ks=	0.01mm
5
6					θ=	0.002
7					V=	0.31
8					DH=	1.818182
9					Re=	563076.6
10
11
12	Iteration	V(m/s)	f	Cchezy	Vnew(m/s)				Iteration	V(m/s)	f	Cchezy	Vnew(m/s)
13	1	0.31	0.013	77.80102	0.309904309				1	0.1	0.016	70.0887	0.279183873
14	2								2	0.279184	0.013203	77.09838	0.307105503
15	3								3	0.307106	0.012983	77.74775	0.309692126
16	4								4	0.309692	0.012965	77.80102	0.309904309
17	5								5
18
Sayfa1

Cell Formulas
Range	Formula
A4	A4	=1/SQRT(B1)
B4	B4	=-2*LOG10((F4*0.001/3.71/F8)+(2.51)/F9/SQRT(B1))
C4	C4	=A4-B4
F8	F8	=4*(F1*F2)/(2*F1+F2)
F9	F9	=(1000*F7*F8)/0.001
B13	B13	=F7
C13	C13	=B1
D13	D13	=SQRT(8*9.81/C13)
E13	E13	=D13*SQRT(0.25*F8*SIN(RADIANS(F6)))

 

[BSALV]

Sub Promise()
     
     Set c = Range("J13") 'topleft-cell writing iteration results
     c.Resize(10, 4).ClearContents

     For i = 1 To 10                                            'max 10 iterations
          Range("C4").GoalSeek Goal:=0, ChangingCell:=Range("B1")     'your goalseek
          With Range("B13:E13")                                 'the wanted results are in B13:E13
               c.Resize(, 4).Offset(i - 1).Value = .Value       'copy them hardcoded to the 4 next lines
          End With

          If Abs(Range("F7").Value - Range("E13").Value) < 0.00001 Then     'difference between old and new v less than ...
               Exit For                                         'stop looping
          Else
               Range("F7").Value = Range("E13").Value           'new V
          End If
     Next
End Sub

 

[promise899]

Sub Promise()
    
     Set c = Range("J13") 'topleft-cell writing iteration results
     c.Resize(10, 4).ClearContents

     For i = 1 To 10                                            'max 10 iterations
          Range("C4").GoalSeek Goal:=0, ChangingCell:=Range("B1")     'your goalseek
          With Range("B13:E13")                                 'the wanted results are in B13:E13
               c.Resize(, 4).Offset(i - 1).Value = .Value       'copy them hardcoded to the 4 next lines
          End With

          If Abs(Range("F7").Value - Range("E13").Value) < 0.00001 Then     'difference between old and new v less than ...
               Exit For                                         'stop looping
          Else
               Range("F7").Value = Range("E13").Value           'new V
          End If
     Next
End Sub

Thanks For iteration table, dont need to copy to 4 next lines I did thing for showing that. (it can be start from B13 dont copy please)

Also this makro only give last row of the table. I need all row and column of the table as in photo . Thank you very much

 

[BSALV]

Sub Promise()
     Range("I1").Resize(, 6).EntireColumn.ClearContents
     Set c2 = Range("A1:F13")                                   'block to copy

     For i = 1 To 10                                            'max 10 iterations
          Range("C4").GoalSeek Goal:=0, ChangingCell:=Range("B1")     'your goalseek

          Set c1 = Range("I" & Rows.Count).End(xlUp).Offset(2)  'next free line
          c1.Value = "iteration " & i                           'write iteration
          c1.Offset(1).Resize(c2.Rows.Count, c2.Columns.Count).Value = c2.Value     'hardcopy of block
          c1.Offset(c2.Rows.Count + 2).Value = "end"            'mark end

          If Abs(Range("F7").Value - Range("E13").Value) < 0.00001 Then     'difference between old and new v less than ...
               Exit For                                         'stop looping
          Else
               Range("F7").Value = Range("E13").Value           'new V
          End If
     Next
     c1.Resize(, 6).EntireColumn.AutoFit

End Sub

 

[promise899]

Sub Promise()
     Range("I1").Resize(, 6).EntireColumn.ClearContents
     Set c2 = Range("A1:F13")                                   'block to copy

     For i = 1 To 10                                            'max 10 iterations
          Range("C4").GoalSeek Goal:=0, ChangingCell:=Range("B1")     'your goalseek

          Set c1 = Range("I" & Rows.Count).End(xlUp).Offset(2)  'next free line
          c1.Value = "iteration " & i                           'write iteration
          c1.Offset(1).Resize(c2.Rows.Count, c2.Columns.Count).Value = c2.Value     'hardcopy of block
          c1.Offset(c2.Rows.Count + 2).Value = "end"            'mark end

          If Abs(Range("F7").Value - Range("E13").Value) < 0.00001 Then     'difference between old and new v less than ...
               Exit For                                         'stop looping
          Else
               Range("F7").Value = Range("E13").Value           'new V
          End If
     Next
     c1.Resize(, 6).EntireColumn.AutoFit

End Sub

Doesn t work:/

Watch goalseek2 | Streamable

Watch "goalseek2" on Streamable.

streamable.com