我正在尝试使用编写并共享的宏作为1999年发布的supplemental material的scientific paper。 我相信宏已经在Excel 1997环境下编写。 不幸的是，我对VBA-Excel知之甚少，据我所知，可能存在一个方法调用问题。选择或.Range为ActiveSheet，因为/和Excel 1997之间不兼容现在Excel 2010（我正在使用的那个）。
似乎VBA-Excel环境具有相当强大的调试界面，尽管我对这种语言的了解不足以使我自己无法充分理解调试。
我的问题是：您可以尝试运行宏，面对错误和相应的错误消息，并修复（或帮我修复）代码吗？
非常感谢。
这是宏：
'
'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
可以尝试使用以下数据集嵌入工作表中的宏：
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
再次感谢。
答案 0 :(得分：0)
一些简单的问题：
Cells(1, 3).Formula = " =B1*0.0015468"
需要： 单元格（1,3）。公式=“= B1 * 0.0015468”
没有'='符号前的空格。
另外，
xlTopToBotom拼写错误 - 需要xlTopToBottom。同样，x1FillDefault必须是xlFillDefault（XL起点，而不是X1）
答案 1 :(得分：0)
这是代码的更新版本。我做了以下事情：
代码首先删除旧数据（生成的图表和表格）
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