Ошибка 400, 1004 в VBA-Excel

Question

Я пытаюсь использовать макрос, написанный и разделяемый как supplemental material из scientific paper, опубликованный в 1999 году. Я считаю, что макрос был написан в среде Excel 1997. К сожалению, у меня очень плохое знание VBA-Excel, и насколько я понял, может возникнуть проблема с вызовом метода. Выберите или. Изменить для 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 

Еще раз спасибо.

Answer 1

Вот обновленная версия кода. Я сделал следующее:

• Заявлен и сортирую все переменные
• Учитывая код хорошей структуры (вкладка-накрест)
• Сделаны коды, выполняемые в фоновом режиме (ускоренный код от 10с до> 1 сек)

• код начинается с удаления старых данных (сгенерированные диаграммы и таблицы)

  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

Пар простых вопросов:

Cells(1, 3).Formula = " =B1*0.0015468" 

должны быть: Cells (1, 3) .Formula = "= B1 * 0,0015468"

без пространства перед знаком '='.

Кроме того, xlTopToBotom с ошибкой - это должно быть xlTopToBottom. Аналогичным образом, x1FillDefault должен быть xlFillDefault (XL в начале, а не X1)