Error 400, 1004 in VBA-Excel - vba

Question

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.

Answer 1

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

Answer 2

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)