Программа для построения информационных сетей для математических моделей

Sub Start() 
  UserForm1.Show 1 
  NF = UserForm1.n 
  SV = UserForm1.s 
  F = UserForm1.Factors 
  Nopt = UserForm1.Nopt 
End Sub

Function SumN(a As Integer, b As Integer, M As Integer, ByRef s 
As Integer, ByRef p As Integer) 
 s = a + b 
 p = 0 
 If s >= M Then 
  p = Int(s / M) 
  s = s - M 
 End If 
End Function

Function  MultN(a  As  Integer,  b  As  Integer,  M  As  Integer)  As 
Integer 
 s = a * b 
 If s >= M Then 
  p = Int(s / M) 
  s = s - M 
 End If 
 MultN = s 
End Function 
Вывод построенной информационной сети 
Вычисление количества факторов и количество необходимых опытов. 
 n = Val(TextBox1.Text) 
 s = Val(TextBox2.Text) 
 F = (s ^ n - 1) / (s - 1) 
 Nopt = s ^ n 
 Factors = F 
Составление групп координат вершин связок плоскостей на бесконечности 
For i = 1 To n 
   V(1, i) = 0 'обнуление первой строки таблицы 
 Next 
 V(1, n) = 1 'начальное значение младшего разряда 
 p = n 'значение номера первого ненулевого разряда 
 k = 2 
 Vp(1) = 1 'первая вершина фундаментального симплекса 
 For i = 2 To F 
   For j = 1 To n 
      V(i, j) = V(i - 1, j) 'копия пред. строки 
   Next 
    
    SumN V(i - 1, n), 1, s, x, y 'прибавление 1 по модулю s 
    V(i, n) = x 
    j = n - 1 
    While y > 0 And j >= 0 'перенос в старший разряд если сумма 
>s 
      SumN V(i, j), y, s, x, y 
      V(i, j) = x 
      j = j - 1 
    Wend 
    'порверка если первая ненулевая координата > 1 
    'тогда осуществляем перенос в старший разряд по модулю 2 
    If V(i, p) > 1 Then 
      V(i, p) = 0 
      j = p - 1 
      y = 1 
      Vp(k)  =  i  'запоминаем  номер  вершины  фундаментального 
симплекса 
      k = k + 1 
      While y > 0 And j >= 0 
        SumN V(i, j), y, s, x, y 
        V(i, j) = x 
        p = j 
        j = j - 1 
      Wend 
    End If 
 Next 
Процедура построения ортогональной таблицы 
'сортируем вершины фунд. симплекса в порядке убывания 
 For i = 1 To n 
   For j = 1 To n 
     T = V(i, j) 
     V(i, j) = V(Vp(i), j) 
     V(Vp(i), j) = T 
   Next j 
 Next 
 Dim Vt() As Integer 
 ReDim Vt(1 To n, 1 To n) 
 For i = n To 1 Step -1 
  For j = 1 To n 
    Vt((n + 1) - i, j) = V(i, j) 
  Next j 
 Next i 
 For i = 1 To n 
  For j = 1 To n 
    V(i, j) = Vt(i, j) 
  Next j 
 Next i 
 
 Dim st As String 
 'заполнение таблицы 
 Dim Info() As Integer 
 ReDim Info(1 To Nopt, 1 To F) 
 For i = 1 To n 
   Info(1, i) = 0 ' заполняем первую строку 0 
 Next 
 'заполнение первых n-столбцов таблицы 
 For i = 2 To Nopt 
   SumN Info(i - 1, n), 1, s, x, y 
   Info(i, n) = x 
   For j = n - 1 To 1 Step -1 
     SumN Info(i - 1, j), y, s, Sum, y 
     Info(i, j) = Sum 
   Next j 
 Next i 
 Dim mult As Integer 
 For i = 1 To Nopt 
   For j = n + 1 To F 
     Sum = 0 
     For k = 1 To n 
       mult = MultN(Info(i, k), V(j, k), s) 
       SumN mult, Sum, s, Sum, p 
     Next 
     Info(i, j) = Sum 
   Next j 
 Next i 
 'вывод результата 
 Dim ws As Worksheet 
 Set  ws  = 
ActiveWorkbook.Sheets.Add(Before:=Worksheets(Worksheets.Count)) 
 ws.Activate 
 Set Me.OutWorkSheet = ws 
 For i = 1 To Nopt 
    ActiveSheet.Cells(i + 1, 1) = i 
 Next 
 'вывод линейно-независимых векторов 
 For i = 1 To F 
  st = "" 
  For j = 1 To n 
    st = st + Str(V(i, j)) 
    If j < n Then st = st + " " 
  Next 
  ActiveSheet.Cells(1, i + 1) = st 
  ActiveSheet.Cells(1, i + 1).Font.Bold = True 
 Next 
 'вывод ортогональной таблицы 
 For i = 1 To Nopt 
  For j = 1 To F 
    ActiveSheet.Cells(i + 1, j + 1) = Info(i, j) 
    ActiveSheet.Cells(1, i + 1).Font.Name = "Tahoma" 
    ActiveSheet.Cells(1, i + 1).Font.Bold = False 
    ActiveSheet.Cells(1, i + 1).Font.Size = 9 
  Next j 
 Next i 
 Hide 
End Sub 
Процедура построения информационной сети 
Sub ИнформационнаяСеть() 
    Dim R As Range 
    Set  R  =  Application.InputBox("Укажите  диапазон  со 
значениями факторов по уровням варьирования", _ 
    , , , , , , 8) 
    If SV <> R.Rows.Count Then 
      MsgBox  "Неверно  указано  количество  уровней  варьирования, 
должно быть " & SV, vbCritical 
      Exit Sub 
    End If 
    MsgBox  "Вы  выбрали  "  &  R.Columns.Count  &  " факторов и " & 
R.Rows.Count & " уровней варьирования" 
    Dim SF() As Single 
    F = R.Columns.Count 
    ReDim SF(1 To R.Rows.Count, 1 To R.Columns.Count) 
    For i = 1 To R.Rows.Count 
      For j = 1 To R.Columns.Count 
        SF(i, j) = R(i, j) 
      Next j 
    Next i 
    UserForm1.OutWorkSheet.Activate 
     
    Dim Info() As Single 
    ReDim Info(1 To Nopt, 1 To F) 
     
    For i = 1 To R.Columns.Count 
      Set R = Application.InputBox("Укажите столбец для фактора 
№ " & i, , , , , , , 8) 
      R.Font.Bold = True 
      R.Font.Color = RGB(200, 0, 0) 
      For j = 1 To Nopt 
        Info(j, i) = R(j, 1) 
      Next j 
    Next i 
     
    For i = 1 To Nopt 
      For j = 1 To F 
        Info(i, j) = SF(Info(i, j) + 1, j) 
      Next j 
    Next i 
    
    'вывод результат 
    Dim ws As Worksheet 
    Set  ws  = 
ActiveWorkbook.Sheets.Add(Before:=Worksheets(Worksheets.Count)) 
    ws.Activate 
     
    With ActiveSheet 
      .Cells(1, 1) = "Информационная сеть" 
      For i = 1 To Nopt 
        .Cells(i + 1, 1) = i 
        .Cells(i + 1, 1).Font.Bold = True 
        For j = 1 To F 
          .Cells(i + 1, j + 1) = Info(i, j) 
        Next j 
      Next 
    End With 
    
End Sub 
Function SumN(a As Integer, b As Integer, M As Integer, ByRef s 
As Integer, ByRef p As Integer) 
 s = a + b 
 p = 0 
 If s >= M Then 
  p = Int(s / M) 
  s = s - M 
 End If 
End Function 
 
Function  MultN(a  As  Integer,  b  As  Integer,  M  As  Integer)  As 
Integer 
 s = a * b 
 If s >= M Then 
  p = Int(s / M) 
  s = s - M 
 End If 
 MultN = s 
End Function

 Set ws = ActiveWorkbook.Sheets.Add(Before:=Worksheets(Worksheets.Count))
 ws.Activate
 Set R = Application.InputBox("Укажите диапазон со значениями факторов по уровням варьирования", "", 8)
 
  MsgBox "Неверно указано количество уровней варьирования, должно быть: " & SV, vbCritical, ""
Set R = Application.InputBox("Укажите столбец для фактора", "")