I got the wrong output in VBA - is my code wrong? - vba

I wrote this code and the result is shown in the blue column.
`
Sub ematest()
'Calculate alpha for each periods
Dim alphas As Integer 'smoothing factor short moving average
Dim alphal As Integer 'smoothing factor long moving average
alphas = 2 / (Cells(3, 13).Value + 1)
alphal = 2 / (Cells(3, 14).Value + 1)
'Calculate 50 days Exponential MA
'calculate sema
For m = 53 To 6102
Cells(m, 13) = (Cells(m, 5) * alphas) + ((1 - alphas) * Cells(m, 9)) 'for Column M
Next m
'calculate lema
For n = 203 To 6102
Cells(n, 14) = (Cells(n, 5) * alphal) + ((1 - alphal) * Cells(n, 10)) 'for Column N
Next n
End Sub
`
I expect the result as shown in the yellow column where it is calculated by excel function for checking.
Am I missing something or have I make mistake?


The data type being used is 'truncating' the results of your calculation.
Try using a data type of Double instead of Integer.
Run this code example to see the differences caused by the data type.
Sub ematestint()
Dim alphas As Integer
Dim alphal As Integer
alphas = (Worksheets("Sheet1").Cells(3, 13).Value)
alpha1 = (Worksheets("Sheet1").Cells(3, 14).Value)
alphas = alphas + 1
alpha1 = alpha1 + 1
alphas = 2 / alphas
alpha1 = 2 / alpha1
MsgBox "alphas = " & alphas & vbCrLf & "alpha1 =" & alpha1
End Sub
Sub ematestdbl()
Dim alphas As Double
Dim alpha1 As Double
alphas = (Worksheets("Sheet1").Cells(3, 13).Value)
alpha1 = (Worksheets("Sheet1").Cells(3, 14).Value)
alphas = alphas + 1
alpha1 = alpha1 + 1
alphas = 2 / alphas
alpha1 = 2 / alpha1
MsgBox "alphas = " & alphas & vbCrLf & "alpha1 =" & alpha1
End Sub

Related

Do until loop in vba

I written a vba where when i roll 6000 times dice, it will count the number of 1's rolled 2's rolled and so on until number of 6's
Private Sub CommandButton2_Click()
i = 6000
Do Until i < 0
n = Int(1 + Rnd * (6 - 1 + 1))
TextBox1.Text = Range("A1")
TextBox2.Text = Range("A2")
TextBox3.Text = Range("A3")
TextBox4.Text = Range("A4")
TextBox5.Text = Range("A5")
TextBox6.Text = Range("A6")
If n = 1 Then
Range("A1") = Range("A1") + n
ElseIf n = 2 Then
Range("A2") = Range("A2") + n / 2
ElseIf n = 3 Then
Range("A3") = Range("A3") + n / 3
ElseIf n = 4 Then
Range("A4") = Range("A4") + n / 4
ElseIf n = 5 Then
Range("A5") = Range("A5") + n / 5
ElseIf n = 6 Then
Range("A6") = Range("A6") + n / 6
End If
i = i - 1
Loop
End Sub
It works fine but the problem is it loads so slow, is there a way to fasten this code ?

Please try this code. It will give the result instantly.
Private Sub CommandButton2_Click()
Dim Arr(1 To 6) As Integer
Dim n As Integer ' random number: 1 to 6
Dim i As Long ' loop counter: turns
Randomize
For i = 1 To 6000
n = Int(1 + Rnd * (6 - 1 + 1))
Arr(n) = Arr(n) + 1
Next i
Range("A1").Resize(UBound(Arr)).Value = Application.Transpose(Arr)
For i = 1 To UBound(Arr)
Me.Controls("TextBox" & i).Value = Arr(i)
Next i
End Sub
The interaction between text boxes and worksheet cells isn't clear. It's easy to establish in any way you want.

Option Explicit
Private Sub CommandButton2_Click()
Dim i As Long
Dim n As Long
Dim results As Variant
results = Array(0, 0, 0, 0, 0, 0)
' read results from cells A1 - A6
For i = 1 To 6
results(i - 1) = Cells(1, i).Value
Next i
' roll the dice 6000 times
For i = 1 To 6000
n = Int(Rnd * 6)
results(n) = results(n) + 1
Next i
' write results to cells A1 - A6
For i = 1 To 6
Cells(1, i).Value = results(i - 1)
Next i
End Sub

VBA IF statement not finding indicated marker

There is a moment where the program has t = 1 but my if statement wont find it.
what gives?
Most of the question is code to fully experiment with the issue
What i am trying to do with my if statement is to find when t = whole number integers example 1,2,3,4,5 then do stuff to return other results but i cant find the moments when t= 1 so im stuck
Dim neq As Double
neq = 2
Dim e As Double
e = Exp(1)
Dim t_int As Integer
t_int = 5
'''''COUNTERS
Dim i As Integer
Dim j As Integer
Dim colOf As Integer
'''''EQUATION CONTROL
Dim h(3) As Double
Dim n As Double
'''''EQUATION CONTROL
Dim u() As Double
Dim uStar() As Double
Dim uOld() As Double
Dim uEx As Double
'''''EQUATION CONTROL
Dim f() As Double
Dim fOld() As Double
'''''EQUATION CONTROL
Dim t As Double
Dim tOld As Double
Dim tNew As Double
'''''SIZING ARRAY
ReDim u(neq)
ReDim uOld(neq)
ReDim uStar(neq)
ReDim f(neq)
ReDim fOld(neq)
'''''INITAL VAULES
h(1) = 0.1
h(2) = 0.05
h(3) = 0.025
u(1) = 2
u(2) = 0
colOf = 12
For j = 1 To 1
Cells(1, 1 + colOf) = "h(" & j & ") = " & h(j)
Cells(2, 1 + colOf) = "t"
Cells(2, 2 + colOf) = "u(1)"
Cells(2, 3 + colOf) = "u(2)"
Cells(2, 4 + colOf) = "uEx"
For n = 1 To (t_int / h(j))
tOld = t
t = tOld + h(j)
For i = 1 To neq
uOld(i) = u(i)
Next i
For i = 1 To neq
fOld(i) = fDeriv(uOld, tOld, i)
uStar(i) = uOld(i) + h(j) * fOld(i)
Next i
For i = 1 To neq
f(i) = fDeriv(uStar, t, i)
u(i) = uOld(i) + (h(j) * (fOld(i) + f(i))) / 2
Next i
i = i - 1
uEx = 2 * e ^ -t * (Cos((3 ^ 0.5) * t) + ((3 ^ 0.5) ^ -1) * Sin((3 ^ 0.5) * t))
Cells(n + 2, 1 + colOf) = t
Cells(n + 2, 2 + colOf) = u(1)
Cells(n + 2, 3 + colOf) = u(2)
Cells(n + 2, 4 + colOf) = uEx
**If t = 1 Then Debug.Print t**
Next n
colOf = colOf + 5
Next j

Error 91 VBA Excel

I got error 91 when I execute my code in VBA
There is my code
Sub Traingulation()
Dim table As Range
Dim tableRows As Integer
Dim tableCols As Integer
Dim ws As Worksheet
Set table = ws.Cells
tableRows = ws.UsedRange.Rows.Count
tableCols = ws.UsedRange.Columns.Count
Dim x1 As Double
Dim x2 As Double
Dim x3 As Double
Dim y1 As Double
Dim y2 As Double
Dim y3 As Double
Dim r1 As Double
Dim r2 As Double
Dim r3 As Double
Dim phase1 As Double
Dim phase2 As Double
Dim phase3 As Double
Dim frequence1 As Double
Dim frequence2 As Double
Dim frequence3 As Double
Dim A As Double
Dim B As Double
Dim C As Double
Dim D As Double
Dim E As Double
Dim F As Double
Dim Xu As Double
Dim Yu As Double
x1 = Range("L5").Value
x2 = Range("L6").Value
x3 = Range("L7").Value
y1 = Range("M5").Value
y2 = Range("M6").Value
y3 = Range("M7").Value
For i = 1 To table1Rows
For j = 1 To table1Cols
If table(i, 5).Value = 1 Then
phase1 = table(i, 2).Value & frequence1 = table(i, 3).Value
End If
Next
If table(i, 5).Value = 2 Then
phase1 = table(i, 2).Value & frequence1 = table(i, 3).Value
End If
Next
If table(i, 5).Value = 3 Then
phase1 = table(i, 2).Value & frequence1 = table(i, 3).Value
End If
r1 = -(3 * 10 ^ 8 * phase1) / 4 * 3.14 * frequence1
r2 = -(3 * 10 ^ 8 * phase2) / 4 * 3.14 * frequence2
r3 = -(3 * 10 ^ 8 * phase3) / 4 * 3.14 * frequence3
A = x3 - x1
B = y3 - y1
C = x3 - x2
D = y3 - y2
E = ((r1) ^ 2 - (r3) ^ 2) - ((x1) ^ 2 - (x3) ^ 2) - ((y1) ^ 2 - (y3) ^ 2)
F = ((r2) ^ 2 - (r3) ^ 2) - ((x2) ^ 2 - (x3) ^ 2) - ((y2) ^ 2 - (y3) ^ 2)
Xu = 0.5 * ((F * B) - (D * E)) / ((C * D) - (A * D))
Yu = (0.5 * E / B) - (A * ((F * B) - (D * E))) / (B * ((C * B) - (A * B)))
MsgBox "Triangulation : Xu = " & Xu & ", et Yu = : " & Yu & " "
End Sub

Define your worksheet here:
Set table = ActiveSheet.Cells
tableRows = ActiveSheet.UsedRange.Rows.Count
tableCols = ActiveSheet.UsedRange.Columns.Count

Error 400, 1004 in VBA-Excel

I am trying to use a macro written and shared as the supplemental material of a scientific paper published in 1999.
I believe the macro has been written under Excel 1997 environment.
Unfortunately, I have very poor knowledge of VBA-Excel, and as far as I could understand, there might be a problem regarding the call of method .Select or .Range for the ActiveSheet, due to/along with an incompatibility between Excel 1997 and nowadays Excel 2010 (the one I am using).
It seems that VBA-Excel environment has quite a powerful debugging interface, although my poor knowledge of this language doesn't provide sufficient understanding to debug by myself.
My question is: can you try to run the macro, face the bug and corresponding error message, and fix (or help me fixing) the code?
Thank you very much.
Here is the macro:
'
'PSD MACRO
'Macro 7/24/97 by Wayne Lukens
'
'New Sheet Column assignments
'1 - Pressure, Pr = p/p0
'2 - Gas Volume adsorbed, Vg
'3 - Volume adsorbed as liquid, V1
'4 - Critical thickness, Tcr
'5 - Critical Radius, Rcr
'6 - Critical Pressure for Rave, Pave
'7 - Critical Thickness for Rave, Pave
'8 - Average Pore Radius, Rave
'9 - Average Pore Diameter, Dave
'10 - Volume of the Kelvin cores, Vc
'11 - Cross Sectional Area
'12 - Number of pores at a given pressure, Lp
'13 - Total volume of pores of radius Rave, Vc
'14 - Volume of gas desorbed in a step, Vd
'15 - Dave again
'
Sub PSD()
'
'Set up variables
'
Dim Pr(100), Rcr(100), V1(100), Tcr(100), Vd(100), Csa(100), Vc(100), Pave(100)
Dim PoreV(100), Lp(100), Tave(100), Rc(100), Rave(100), Te(100, 100)
Dim Te1 As String
Dim C(10), T, f, df, dx, Tlast As Double
PageTitle = "Adsorp in "
MeniscusTitle = "Hemisperical Meniscus"
Pi = 3.14159
a = 5 * (3.54 ^ 3)
' factoroot = 4.05*Log(10)
R = 0.8314
T = 77.2
RT = R * T
Gamma = 8.72
Vm = 34.68
factoroot = 2 * Gamma * Vm / (R * T)
PoreType = ""
' Welcome = MsgBox("Welcome to Broekhoff-de-Boer analysis with a Frenkel-Halsey-Hill isotherm.",vbOKOnly)
On Error Resume Next
Set dData = Application.InputBox("Please select the cells which contain your isotherm data. The data must " & "contain p/p0 in column 1 and the volume of gas adsorbed (as gas) in column 2.", "Select Isotherm Data", Type:=8)
If Err <> 0 Then
On Error GoTo 0
Exit Sub
End If
On Error GoTo 0
'
'Get information from the user to determine pore model and meniscus shape
'
Do Until PoreType = "sphere" Or PoreType = "s" Or PoreType = "cylinder" Or PoreType = "c" Or PoreType = False
PoreType = Application.InputBox("Which pore model are you using, cylinder or sphere (c or s)?", "Pore Model")
Loop
If PoreType = False Then
Exit Sub
End If
answer1 = MsgBox("Is this an adsorption isotherm?", vbYesNo)
Answer2 = MsgBox("Does the isotherm display hysteresis?", vbYesNo)
alpha = InputBox("What is the value of the FHH parameter, alpha? (Default = 5*3.54^3)", "Enter alpha", a)
If answer1 = vbNo Then
PoreType = "c"
PageTitle = "Desorp from"
End If
If PoreType = "sphere" Or PoreType = "s" Then
ModelSheet = "Spheres"
PoreType = "s"
factory = factoroot
PoreTitle = "Spherical Pores"
Else
ModelSheet = "Cylinders"
PoreType = "c"
factory = factoroot / 2
PoreTitle = "Cylindrical Pores"
End If
If Answer2 = vbNo Then ModelSheet = ModelSheet & "no Hy"
If alpha = "" Then
Exit Sub
End If
If answer1 = vbYes Then
celltitle = "Adsorption in " & ModelSheet
Else
celltitle = "Desorption from " & ModelSheet
End If
ModelSheet = PageTitle & ModelSheet
'
'Copy selected data to new sheets.
'
ActiveSheet.Activate
dData.Select
Selection.Copy
'Application.Workbook.Add
ActiveSheet.Activate
Sheets.Add
ActiveSheet.Paste
ActiveSheet.Name = ModelSheet
Sheets(ModelSheet).Activate
Selection.Sort Key1:=ActiveCell, Order1:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBotom
'
'Convert gas volumes into liquid volumes
'
iRows = Selection.Rows.Count
Cells(1, 3).Formula = " =B1*0.0015468"
Cells(1, 3).Select
Selection.AutoFill Destination:=Range(Cells(1, 3), Cells(iRows, 3)), Type:=x1FillDefault
'
'Fill array
'
For I = 1 To iRows
Pr(I) = Cells(I, 1)
V1(I) = Cells(I, 3)
Next I
If answer1 = vbNo Or Answer2 = vbNo Then
'
'Calculate Critical Radius and Pore Diameter at each Pressure for a Desorption Branch
'
If answer1 = vbNo Then
BranchTitle = "Desorption from"
Else
BranchTitle = "Adsorption w/o Hysteresis" & Chr(13) & "in"
End If
fa = factoroot / 2
For I = 1 To iRows
Inp = -Log(Pr(I))
THigh = 5 * (alpha / Inp) ^ (1 / 3)
TLow = 0.5 * (alpha / Inp) ^ (1 / 3)
T = 3 * (alpha / Inp) ^ (1 / 3)
C(1) = alpha * alpha / Inp
C(2) = 0#
C(3) = -2 * alpha * fa / Inp
C(4) = -2 * alpha
C(5) = 0#
C(6) = fa
C(7) = Inp
For K = 1 To 20
f = C(1) + T * T * (C(3) + T * (C(4) + T * T * (C(6) + T * C(7))))
df = T * (2 * C(3) + T * (3 * C(4) + T * T * (5 * C(6) + T * 6 * C(7))))
dx = f / df
If dx > 0 Then
THigh = T
End If
If dx < 0 Then
TLow = T
End If
T = T - dx
If (Abs(dx) < 0.00000000000001) Then Exit For
If T > THigh Then
T = (THigh + Tlast) / 2
End If
If T < TLow Then
T = (TLow + Tlast / 2)
End If
Tlast = T
Next K
Tcr(I) = T
Cells(I, 4) = T
Rcr(I) = Tcr(I) + fa / (Inp - alpha / (Tcr(I) ^ 3))
Next I
Else
'
'Calculate Critical Radius and Pore Diameter at each pressure for an Adsorption Branch
'
If PoreType = "c" Then MeniscusTitle = "Cylindrical Meniscus"
BranchTitle = "Adsorption in"
For I = 1 To iRows
logprel = Log(Pr(I))
q = -((alpha * factory / 3) ^ 0.5) / logprel
R = alpha / (2 * logprel)
If R ^ 2 < q ^ 3 Then
x = R / Sqr(q ^ 3)
theta = Atn(-x / Sqr(-x * x + 1)) + 1.5708
root2 = -2 * Sqr(q) * Cos((theta + 2 * 3.14159) / 3)
Tcr(I) = root2
Else
a = -Sgn(R) * (Abs(R) + Sqr(R ^ 2 - q ^ 3)) ^ (1 / 3)
b = q / a
Tcr(I) = a + b
End If
Rcr(I) = Tcr(I) + factory / (-logprel - alpha / Tcr(I) ^ 3)
Next I
End If
'
'Calculate the average pore radius for this desorption step
'
For I = 1 To iRows - 1
Rave(I) = (Rcr(I) + Rcr(I + 1)) * Rcr(I) * Rcr(I + 1) / (Rcr(I) ^ 2 + Rcr(I + 1) ^ 2)
'
'Calculate the critical thickness and pressure for each Rave since Rave is known
'
a = Sqr(factory)
b = Sqr(3 * alpha)
d = -Rave(I) * b
q = -0.5 * (b + Sgn(b) * Sqr(b ^ 2 - 4 * a * d))
Tave(I) = d / q
Pave(I) = Exp(-(factory / (Rave(I) - Tave(I)) + alpha / Tave(I) ^ 3))
Next I
'
'Calculate Equilibrium Thickness at every pressure for each pore radius using the Newton-Raphson method
'
C(2) = alpha
C(3) = 0#
For I = 2 To iRows
Rcrit = Rave(I - 1)
C(1) = -alpha * Rcrit
T = Tcr(I)
For J = I + 1 To iRows + 1
Prel = Pr(J - 1)
Plog = -Log(Prel)
C(5) = -Plog
C(4) = Rcrit * Plog - factory
For K = 1 To 20
f = C(1) + T * (C(2) + T ^ 2 * (C(4) + T * C(5)))
df = C(2) + T * (T * (3 * C(4) + T * 4 * C(5)))
dx = f / df
T = T - dx
If (Abs(dx) < 0.0000000001) Then Exit For
Next K
Te(J - 1, I - 1) = T
Next J
Next I
'
'Do the iterative part of the analysis
'
For I = 1 To iRows - 1
'
'Calculate volume change for all previously opened pores
'
Vd(I) = 0#
If I = 1 Then
Vd(I) = 0#
Else
For J = 1 To I - 1
'
'Calculate the total volume desorbed from the open pores during this interval
'
If PoreType = "s" Then
Vd(I) = Vd(I) + 1E-24 * (4 / 3) * Pi * ((Rave(J) - Te(I + 1, J)) ^ 3 - (Rave(J) - Te(I, J)) ^ 3) * Lp(J)
'Note : In this case, Lp(J) is the number of spherical pores
Else
If PoreType = "c" Then
Vd(I) = Vd(I) + 1E-16 * Pi * ((Rave(J) - Te(I + 1, J)) ^ 2 - (Rave(J) - Te(I, J)) ^ 2) * Lp(J)
'Note : in this case, Lp(J) is the length of the cylindrical pore in cm.
Else
sorry = MsgBox("error at Vd(I) stae", vbOKOnly)
Exit Sub
End If
End If
Next J
End If
'
'Determine what's going on
'
If Vd(I) >= (V1(I) - V1(I + 1)) Then
'
'The volume desorbed is less than the volume expected from desorption from opened pores, set the volume of the new pores to zero
'
'
Lp(I) = 0#
Vc(I) = 0#
Csa(I) = 0#
Else
'
'The volume desorbed is greater thant the volume expected, so the new pores must have opened
'
Vc(I) = V1(I) - V1(I + 1) + Vd(I)
'
'Calculate the volume of the newly opened pores in cm3 at the end of the interval
'
If PoreType = "s" Then
Csa(I) = 4E-24 * (Pi / 3) * (Rave(I) - Te(I + 1, I)) ^ 3
Else
If PoreType = "c" Then
Csa(I) = Pi * 1E-16 * (Rave(I) - Te(I + 1, I)) ^ 2
Else
sorry = MsgBox("error at Csa calculation", vbOKOnly)
Exit Sub
End If
End If
'
'Calculate the number of pores
'
Lp(I) = Vc(I) / Csa(I)
End If
'
'Write values of important numbers to the worksheet"
'
If PoreType = "s" Then
PoreV(I) = 4E-24 * (Pi / 3) * Lp(I) * Rave(I) ^ 3
Else
If PoreType = "c" Then
PoreV(I) = 1E-16 * Lp(I) * Pi * Rave(I) ^ 2
Else
sorry = MsgBox("error at PoreV calculation", vbOKOnly)
Exit Sub
End If
End If
Next I
'
'Do calculations for Incremental Pore Volumee
'
Bigpoint = 0
BigPointNumber = 1
CumSA = 0
CumPV = 0
For J = 1 To iRows - 1
Cells(J, 4) = Tcr(J)
Cells(J, 5) = Rcr(J)
Cells(J, 6) = Pave(J)
Cells(J, 7) = Tave(J)
Cells(J, 8) = Rave(J)
Cells(J, 9) = Rave(J) * 2
Cells(J, 10) = Vc(J)
Cells(J, 11) = Csa(J)
Cells(J, 12) = Lp(J)
Cells(J, 13) = PoreV(J)
Cells(J, 14) = Vd(J)
Cells(J, 15) = Rave(J) * 2
Cells(J, 16) = PoreV(J)
If Rave(J) < 10 Then Exit For
If Cells(J, 16) > Bigpoint Then
BigPointNumber = J
Bigpoint = Cells(J, 16)
End If
'
'Calculate Surface Area in m2/g
'
If PoreType = "s" Then
Cells(J, 17) = 4E-20 * Pi * Lp(J) * Rave(J) ^ 2
Else
If PoreType = "c" Then
Cells(J, 17) = 0.000000000002 * Pi * Lp(J) * Rave(J)
Else
sorry = MsgBox("Error at cumulative surface area calculation", vbOKOnly)
Exit Sub
End If
End If
CumSA = CumSA + Cells(J, 17)
CumPV = CumPV + PoreV(J)
Cells(J, 18) = CumSA
Cells(J, 19) = CumPV
Next J
'
'Give Cells Headings
'
Cells(1, 1).Select
Selection.EntireRow.Insert
Cells(1, 1) = "Rel pres"
Cells(1, 2) = "Vol as gas"
Cells(1, 3) = "vol as liq"
Cells(1, 4) = "Crit thick"
Cells(1, 5) = "Crit radius"
Cells(1, 6) = "Avg pres"
Cells(1, 7) = "Avg thick"
Cells(1, 8) = "Avg radius"
Cells(1, 9) = "Avg diam"
Cells(1, 10) = "Vol cores"
Cells(1, 11) = "X sect area"
Cells(1, 12) = "Pore length"
Cells(1, 13) = celltitle
Cells(1, 14) = "Vol desorp"
Cells(1, 15) = "Avg diam"
Cells(1, 16) = celltitle
Cells(1, 17) = "Surf area"
Cells(1, 18) = "Cumul SA"
Cells(1, 19) = "Cumul PoreV"
SurfaceArea = Fix(CumSA + 0.5)
PoreVolume = Fix(100 * CumPV + 0.5) / 100
'
'Create a chart
'
Columns("O:O").Select
Selection.NumberFormat = "0"
Charts.Add
ActiveChart.ChartWizard Source:=Sheets(ModelSheet).Range("$O:$P"), Gallery:=xlXYScatter, Format:=2, PlotBy:=xlColumns, CategoryLabels:=1, SeriesLabels:=1, HasLegend:=2, Title:="Plot for" & celltitle, CategoryTitle:="Pore Diameter in Angstroms", ValueTitle:="Pore Volume in cc per gram", ExtraTitle:=""
ActiveChart.PlotArea.Select
Nombre = ModelSheet & "Plot"
ActiveSheet.Name = Nombre
End Sub
One can try the macro with the following set of data to embed in the sheet:
0.0106908 103.046
0.031249 120.144
0.0515578 129.808
0.0772499 138.616
0.100304 144.98
0.120399 149.797
0.140559 154.187
0.160819 158.255
0.18104 162.065
0.20132 165.698
0.24889 173.67
0.278214 178.398
0.303499 182.434
0.350487 189.809
0.375365 193.778
0.400622 197.828
0.425556 201.949
0.450624 206.146
0.475636 210.459
0.50072 214.991
0.525794 219.652
0.550631 224.562
0.575897 229.666
0.600643 235.066
0.625847 240.934
0.650973 247.074
0.675899 253.657
0.701025 260.816
0.725913 268.534
0.75098 277.212
0.776003 287.031
0.801318 298.016
0.813639 304.484
0.826658 311.591
0.838517 318.99
0.851442 327.799
0.863629 337.611
0.876573 349.305
0.888307 362.915
0.900328 383.552
0.911067 419.354
0.92187 475.714
0.952079 631.959
0.97104 817.134
0.979005 1038.01
0.984323 1250.95
0.99039 1436.81
Thanks again.

Here's an updated version of the code. I've done the following:
Declared and sorted all variables
Given the code a good structure (tab-wise)
Made the code run in background (speeded up code from 10s to >1s)
The code begins with removing old data (generated charts and sheets)
Option Explicit
' Books & Sheets
Dim Wb1 As Workbook
Dim Sh1 As Worksheet, Sh2 As Worksheet
' Doubles: One letter
Dim A As Double, B As Double, D As Double, F As Double, J As Double, K As Double
Dim R As Double, Q As Double, T As Double, X As Double
' Doubles: Two letters
Dim dF As Double, dX As Double, fA As Double, Vm As Double, Rt As Double, Pi As Double
' Doubles: Three or more letters
Dim Alpha As Double, BigPoint As Double, BigPointNumber As Double, CumSA As Double, CumPV As Double
Dim Factory As Double, Gamma As Double, Inp As Double, LogpRel As Double, pLog As Double
Dim PoreVolume As Double, pRel As Double, rCrit As Double, Root2 As Double, SurfaceArea As Double
Dim Theta As Double, tHigh As Double, tLast As Double, tLow As Double
' Doubles: Arrays
Dim C(10) As Double, Csa(100) As Double, Lp(100) As Double, Pave(100) As Double, PoreV(100) As Double
Dim Pr(100) As Double, Rave(100) As Double, Rc(100) As Double, Rcr(100) As Double, Tave(100) As Double
Dim Tcr(100) As Double, Te(100, 100) As Double, V1(100) As Double, Vc(100) As Double, Vd(100) As Double
' Longs
Dim i&, iRows&
' Strings ($)
Dim BranchTitle$, CellTitle$, FactoRoot$, MeniscusTitle$, ModelSheet$
Dim PageTitle$, PoreTitle$, PoreType$, Spheres$, Te1$
' Booleans (True or False)
Dim Answer1 As Boolean, Answer2 As Boolean
' Range
Dim dData As Range
' PSD MACRO
' Macro 7/24/97 by Wayne Lukens
'
' New Sheet Column assignments
' 1 - Pressure, Pr = p/p0
' 2 - Gas Volume adsorbed, Vg
' 3 - Volume adsorbed as liquid, V1
' 4 - Critical thickness, Tcr
' 5 - Critical Radius, Rcr
' 6 - Critical Pressure for Rave, Pave
' 7 - Critical Thickness for Rave, Pave
' 8 - Average Pore Radius, Rave
' 9 - Average Pore Diameter, Dave
' 10 - Volume of the Kelvin cores, Vc
' 11 - Cross Sectional Area
' 12 - Number of pores at a given pressure, Lp
' 13 - Total volume of pores of radius Rave, Vc
' 14 - Volume of gas desorbed in a step, Vd
' 15 - Dave again
Sub PSD()
' Declare books and sheets
Set Wb1 = ThisWorkbook
Set Sh1 = Wb1.Sheets("Data")
' Delete old sheets if existing (graph and database)
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
On Error Resume Next
Sheets("Adsorp in Cylinders").Delete
Sheets("Adsorp in Spheres").Delete
Sheets("Adsorp in CylindersPlot").Delete
Sheets("Adsorp in SpheresPlot").Delete
Sheets("CylindersPlot").Delete
Sheets("SpheresPlot").Delete
On Error GoTo 0
Application.DisplayAlerts = True
' Set up variables
PageTitle = "Adsorp in "
MeniscusTitle = "Hemisperical Meniscus"
Pi = WorksheetFunction.Pi
A = 5 * (3.54 ^ 3)
' factoroot = 4.05*Log(10)
R = 0.8314
T = 77.2
Rt = R * T
Gamma = 8.72
Vm = 34.68
FactoRoot = 2 * Gamma * Vm / (R * T)
PoreType = ""
' Welcome = MsgBox("Welcome to Broekhoff-de-Boer analysis with a Frenkel-Halsey-Hill isotherm.",vbOKOnly)
On Error Resume Next
Set dData = Application.InputBox("Please select the cells which contain your isotherm data." & _
"The data must " & "contain p/p0 in column 1 and the volume of gas adsorbed (as gas) in column 2.", _
"Select Isotherm Data", Type:=8)
If Err <> 0 Then
On Error GoTo 0
Exit Sub
End If
On Error GoTo 0
' Run everything in background (code runs faster)
Application.ScreenUpdating = False
Set dData = dData.SpecialCells(xlCellTypeConstants) ' Removes all cells but constants from selection
' Get information from the user to determine pore model and meniscus shape
Do Until PoreType = "sphere" Or PoreType = "s" Or PoreType = "cylinder" Or PoreType = "c"
PoreType = Application.InputBox("Which pore model are you using, cylinder or sphere (c or s)?", "Pore Model")
If PoreType = "" Then Exit Sub
Loop
Answer1 = MsgBox("Is this an adsorption isotherm?", vbYesNo)
Answer2 = MsgBox("Does the isotherm display hysteresis?", vbYesNo)
Alpha = InputBox("What is the value of the FHH parameter, alpha? (Default = 5*3.54^3)", "Enter alpha", A)
If Answer1 = False Then
PoreType = "c"
PageTitle = "Desorp from"
End If
If PoreType = "sphere" Or PoreType = "s" Then
ModelSheet = "Spheres"
PoreType = "s"
Factory = FactoRoot
PoreTitle = "Spherical Pores"
Else
ModelSheet = "Cylinders"
PoreType = "c"
Factory = FactoRoot / 2
PoreTitle = "Cylindrical Pores"
End If
If Answer2 = False Then ModelSheet = ModelSheet & "no Hy"
If Alpha = 0 Then Exit Sub
If Answer1 = True Then
CellTitle = "Adsorption in " & ModelSheet
Else
CellTitle = "Desorption from " & ModelSheet
End If
' Copy selected data to new sheets
dData.Copy
Sheets.Add After:=Sh1
ActiveSheet.Paste
ActiveSheet.Name = PageTitle & ModelSheet
Set Sh2 = Wb1.Sheets(PageTitle & ModelSheet)
Selection.Sort Key1:=ActiveCell, Order1:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
' Convert gas volumes into liquid volumes
iRows = Selection.Rows.Count
Cells(1, 3).Formula = "=B1*0.0015468"
Range(Cells(2, 3), Cells(iRows, 3)).Formula = Cells(1, 3).Formula
' Fill array
For i = 1 To iRows
Pr(i) = Cells(i, 1)
V1(i) = Cells(i, 3)
Next i
If Answer1 = False Or Answer2 = False Then
' Calculate Critical Radius and Pore Diameter at each Pressure for a Desorption Branch
If Answer1 = vbNo Then
BranchTitle = "Desorption from"
Else
BranchTitle = "Adsorption w/o Hysteresis" & Chr(13) & "in"
End If
fA = FactoRoot / 2
For i = 1 To iRows
Inp = -Log(Pr(i))
tHigh = 5 * (Alpha / Inp) ^ (1 / 3)
tLow = 0.5 * (Alpha / Inp) ^ (1 / 3)
T = 3 * (Alpha / Inp) ^ (1 / 3)
C(1) = Alpha * Alpha / Inp
C(2) = 0#
C(3) = -2 * Alpha * fA / Inp
C(4) = -2 * Alpha
C(5) = 0#
C(6) = fA
C(7) = Inp
For K = 1 To 20
F = C(1) + T * T * (C(3) + T * (C(4) + T * T * (C(6) + T * C(7))))
dF = T * (2 * C(3) + T * (3 * C(4) + T * T * (5 * C(6) + T * 6 * C(7))))
dX = F / dF
If dX > 0 Then tHigh = T
If dX < 0 Then tLow = T
T = T - dX
If (Abs(dX) < 0.00000000000001) Then Exit For
If T > tHigh Then T = (tHigh + tLast) / 2
If T < tLow Then T = (tLow + tLast / 2)
tLast = T
Next K
Tcr(i) = T
Cells(i, 4) = T
Rcr(i) = Tcr(i) + fA / (Inp - Alpha / (Tcr(i) ^ 3))
Next i
Else
' Calculate Critical Radius and Pore Diameter at each pressure for an Adsorption Branch
If PoreType = "c" Then MeniscusTitle = "Cylindrical Meniscus"
BranchTitle = "Adsorption in"
For i = 1 To iRows
LogpRel = Log(Pr(i))
Q = -((Alpha * Factory / 3) ^ 0.5) / LogpRel
R = Alpha / (2 * LogpRel)
If R ^ 2 < Q ^ 3 Then
X = R / Sqr(Q ^ 3)
Theta = Atn(-X / Sqr(-X * X + 1)) + 1.5708
Root2 = -2 * Sqr(Q) * Cos((Theta + 2 * 3.14159) / 3)
Tcr(i) = Root2
Else
A = -Sgn(R) * (Abs(R) + Sqr(R ^ 2 - Q ^ 3)) ^ (1 / 3)
B = Q / A
Tcr(i) = A + B
End If
Rcr(i) = Tcr(i) + Factory / (-LogpRel - Alpha / Tcr(i) ^ 3)
Next i
End If
' Calculate the average pore radius for this desorption step
For i = 1 To iRows - 1
Rave(i) = (Rcr(i) + Rcr(i + 1)) * Rcr(i) * Rcr(i + 1) / (Rcr(i) ^ 2 + Rcr(i + 1) ^ 2)
' Calculate the critical thickness and pressure for each Rave since Rave is known
A = Sqr(Factory)
B = Sqr(3 * Alpha)
D = -Rave(i) * B
Q = -0.5 * (B + Sgn(B) * Sqr(B ^ 2 - 4 * A * D))
Tave(i) = D / Q
Pave(i) = Exp(-(Factory / (Rave(i) - Tave(i)) + Alpha / Tave(i) ^ 3))
Next i
'Calculate Equilibrium Thickness at every pressure for each pore radius using the Newton-Raphson method
C(2) = Alpha
C(3) = 0#
For i = 2 To iRows
rCrit = Rave(i - 1)
C(1) = -Alpha * rCrit
T = Tcr(i)
For J = i + 1 To iRows + 1
pRel = Pr(J - 1)
pLog = -Log(pRel)
C(5) = -pLog
C(4) = rCrit * pLog - Factory
For K = 1 To 20
F = C(1) + T * (C(2) + T ^ 2 * (C(4) + T * C(5)))
dF = C(2) + T * (T * (3 * C(4) + T * 4 * C(5)))
dX = F / dF
T = T - dX
If (Abs(dX) < 0.0000000001) Then Exit For
Next K
Te(J - 1, i - 1) = T
Next J
Next i
' Do the iterative part of the analysis
For i = 1 To iRows - 1
' Calculate volume change for all previously opened pores
Vd(i) = 0#
If i = 1 Then
Vd(i) = 0#
Else
For J = 1 To i - 1
' Calculate the total volume desorbed from the open pores during this interval
If PoreType = "s" Then
Vd(i) = Vd(i) + 1E-24 * (4 / 3) * Pi * ((Rave(J) - Te(i + 1, J)) ^ 3 - (Rave(J) - Te(i, J)) ^ 3) * Lp(J)
' Note : In this case, Lp(J) is the number of spherical pores
Else
If PoreType = "c" Then
Vd(i) = Vd(i) + 1E-16 * Pi * ((Rave(J) - Te(i + 1, J)) ^ 2 - (Rave(J) - Te(i, J)) ^ 2) * Lp(J)
' Note : in this case, Lp(J) is the length of the cylindrical pore in cm.
Else
MsgBox "Error at Vd(I) stae", vbOKOnly
Exit Sub
End If
End If
Next J
End If
' Determine what's going on
If Vd(i) >= (V1(i) - V1(i + 1)) Then
' The volume desorbed is less than the volume expected from desorption from opened pores, set the volume of the new pores to zero
Lp(i) = 0#
Vc(i) = 0#
Csa(i) = 0#
Else
' The volume desorbed is greater thant the volume expected, so the new pores must have opened
Vc(i) = V1(i) - V1(i + 1) + Vd(i)
' Calculate the volume of the newly opened pores in cm3 at the end of the interval
If PoreType = "s" Then
Csa(i) = 4E-24 * (Pi / 3) * (Rave(i) - Te(i + 1, i)) ^ 3
Else
If PoreType = "c" Then
Csa(i) = Pi * 1E-16 * (Rave(i) - Te(i + 1, i)) ^ 2
Else
MsgBox "Error at Csa calculation", vbOKOnly
Exit Sub
End If
End If
' Calculate the number of pores
Lp(i) = Vc(i) / Csa(i)
End If
' Write values of important numbers to the worksheet
If PoreType = "s" Then
PoreV(i) = 4E-24 * (Pi / 3) * Lp(i) * Rave(i) ^ 3
Else
If PoreType = "c" Then
PoreV(i) = 1E-16 * Lp(i) * Pi * Rave(i) ^ 2
Else
MsgBox "Error at PoreV calculation", vbOKOnly
Exit Sub
End If
End If
Next i
'Do calculations for Incremental Pore Volumee
BigPoint = 0
BigPointNumber = 1
CumSA = 0
CumPV = 0
For J = 1 To iRows - 1
Cells(J, 4) = Tcr(J)
Cells(J, 5) = Rcr(J)
Cells(J, 6) = Pave(J)
Cells(J, 7) = Tave(J)
Cells(J, 8) = Rave(J)
Cells(J, 9) = Rave(J) * 2
Cells(J, 10) = Vc(J)
Cells(J, 11) = Csa(J)
Cells(J, 12) = Lp(J)
Cells(J, 13) = PoreV(J)
Cells(J, 14) = Vd(J)
Cells(J, 15) = Rave(J) * 2
Cells(J, 16) = PoreV(J)
If Rave(J) < 10 Then Exit For
If Cells(J, 16) > BigPoint Then
BigPointNumber = J
BigPoint = Cells(J, 16)
End If
'Calculate Surface Area in m2/g
If PoreType = "s" Then
Cells(J, 17) = 4E-20 * Pi * Lp(J) * Rave(J) ^ 2
Else
If PoreType = "c" Then
Cells(J, 17) = 0.000000000002 * Pi * Lp(J) * Rave(J)
Else
MsgBox "Error at cumulative surface area calculation", vbOKOnly
Exit Sub
End If
End If
CumSA = CumSA + Cells(J, 17)
CumPV = CumPV + PoreV(J)
Cells(J, 18) = CumSA
Cells(J, 19) = CumPV
Next J
'Give Cells Headings
Rows(1).Insert
Cells(1, 1) = "Rel pres"
Cells(1, 2) = "Vol as gas"
Cells(1, 3) = "vol as liq"
Cells(1, 4) = "Crit thick"
Cells(1, 5) = "Crit radius"
Cells(1, 6) = "Avg pres"
Cells(1, 7) = "Avg thick"
Cells(1, 8) = "Avg radius"
Cells(1, 9) = "Avg diam"
Cells(1, 10) = "Vol cores"
Cells(1, 11) = "X sect area"
Cells(1, 12) = "Pore length"
Cells(1, 13) = CellTitle
Cells(1, 14) = "Vol desorp"
Cells(1, 15) = "Avg diam"
Cells(1, 16) = CellTitle
Cells(1, 17) = "Surf area"
Cells(1, 18) = "Cumul SA"
Cells(1, 19) = "Cumul PoreV"
SurfaceArea = Fix(CumSA + 0.5)
PoreVolume = Fix(100 * CumPV + 0.5) / 100
'Create a chart
Columns("O:O").NumberFormat = "0"
Range("A1").Select
ActiveSheet.UsedRange.Columns.AutoFit
Charts.Add After:=Sh1
ActiveChart.ChartWizard Source:=Sheets(PageTitle & ModelSheet).Range("$O:$P"), Gallery:=xlXYScatter, _
Format:=2, PlotBy:=xlColumns, CategoryLabels:=1, SeriesLabels:=1, HasLegend:=2, _
Title:="Plot for" & CellTitle, CategoryTitle:="Pore Diameter in Angstroms", _
ValueTitle:="Pore Volume in cc per gram", ExtraTitle:=""
ActiveSheet.Name = ModelSheet & "Plot"
Calculate
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Couple of simple issues:
Cells(1, 3).Formula = " =B1*0.0015468"
needs to be:
Cells(1, 3).Formula = "=B1*0.0015468"
without the space before the '=' sign.
Also,
xlTopToBotom is misspelled - it needs to be xlTopToBottom. Similarly, x1FillDefault needs to be xlFillDefault (XL at the start, not X1)

Writing data to cells using an initial value

could I get help, I am trying to write data into cells in a spread sheet, using an initial value, then adding a specific increment until it reaches a maximum value also specified. I have included an example below. Thank you.
Min: 0.5
Max: 1.5
Increment: 0.1
wrote the code below, but it runs infinitely...
sub IncrementValue()
Dim iMin, iMax, inc, x As Single
iMin = Range("A1").Value
iMax = Range("A2").Value
Inc = Range("A3").Value
Range("B1").Value = iMin
x = 1
Do
x = x + 1
Range("B" & x).Value = Range("B" & x - 1).Value + Inc
Loop Until Range("B" & x).Value = iMax
End Sub

Sub FillIncrementingSeries(rStart As Range, dMin As Double, dMax As Double, dIncr As Double)
rStart.Value = dMin
rStart.Resize(((dMax - dMin) / dIncr) + 1, 1).DataSeries xlColumns, xlDataSeriesLinear, , dIncr, dMax
End Sub