'シンプレックス法 マクロ
'Linear Programing Program
'2000/8/26 修正：昔プログラムはいけてないから
'無断修正：自分なりに変更
'N：変数の数
'M：制約条件の数
'A(N,M)：シンプレックス タブロー
'BS(M)：基底に入っている変数番号
'Steｐ：繰り返しの回数
'Jma：新しく基底に入る列番号
'Ima：基底から吐出される行番号

Sub 標準シンプレックス法()
  Dim MsgOp As Byte, Sname As String
  Dim bun1 As String, bun2 As String
  Dim OP1 As Byte, OP2 As Byte
  Dim LOC As Byte, DoName As String
  Dim 縦 As Integer, 横 As Integer
  Dim I As Integer, J As Integer


'【コントロール数】
  Range("A1").Select
  Dim N As Byte        '変数の数
  Dim M As Byte        '制約条件の数
  N = ActiveSheet.Cells(2, 3)        '変数の数をC2から取得
  M = ActiveSheet.Cells(3, 3)        '制約式の数をC3から取得
  NN = N * 2
  MM = M * 2
  baseROW = 3  '基本開始位置の縦
  baseCOL = 6  '基本開始位置の横
  tate = baseROW
  yoko = baseCOL
  bun1 = "現在の出力結果を消します。"
  bun2 = "掃き出される行がないため、有限解はありません。"

'【シート消去】
  MsgOp = MsgBox(bun1, vbOKCancel, "領域のクリア")
  If MsgOp = vbCancel Then GoTo Endmsg
  If MsgOp = vbOK Then
    altROW = baseROW + MM + 2        '制約文以下を真っ白に…
    Cells(altROW, 1).Range(Cells(1, 1), Cells(100, 100)).ClearContents
    Cells(altROW, 1).Range(Cells(1, 1), Cells(100, 100)).Font.ColorIndex = 0
    Cells(altROW, 1).Range(Cells(1, 1), Cells(100, 100)).Interior.ColorIndex = 0
  End If

'【データ読込】
  Dim A(50, 50) As Single   '係数行列分子
  Dim B(50, 50) As Single   '係数行列分母
  Dim BS(50) As Single      '基底変数
  Dim Step As Byte          'なんど吐き出しを行ったか
  Dim MinA As Single        '最小値を求めるための一時的変数
  Dim Jma As Byte      'Z行の中で最大の負係数
  Dim Ima As Byte      '掃出し行
  Dim TH As Single     '増加限界
  
  
'【制約条件右辺値ｂｉ目的関数係数ｃjｼﾝﾌﾟﾚｯｸｽﾀﾌﾞﾛｰaij読込み】分子部分
  Cells(baseROW, baseCOL - 1) = "Z="
  For I = 1 To M         '1〜Mまで繰り返す
   A(I, 0) = ActiveSheet.Cells(baseROW + 2 * I, baseCOL - 1)
    '制約条件の定数項をA(I,0)とする
   ActiveSheet.Cells(baseROW + 2 * I, baseCOL + 0) = ">="
    '入力部分の不等号を>=に統一
   For J = 1 To N
    If I = 1 Then
    A(0, J) = -ActiveSheet.Cells(baseROW + 0, baseCOL + J)
     '目的関数をZを最大化するように変化させる
    ActiveSheet.Cells(baseROW - 1, baseCOL + J) = "X" & J
     '表の横の項目はX1,X2と表示させていく
    End If
    A(I, J) = Cells(baseROW + 2 * I, baseCOL + J)
     '変数をA(1,1)からA(M,N)に収納させる
   Next J
  Next I

'【制約条件右辺値ｂｉ目的関数係数ｃjｼﾝﾌﾟﾚｯｸｽﾀﾌﾞﾛｰaij読込み】分母部分
  B(0, 0) = 1
  For I = 1 To M         '1〜Mまで繰り返す
   B(I, 0) = ActiveSheet.Cells(baseROW + 2 * I + 1, baseCOL - 1)
   For J = 1 To N
   If I = 1 Then
    B(0, J) = Cells(baseROW + 1, baseCOL + J)
    End If
    B(I, J) = Cells(baseROW + 2 * I + 1, baseCOL + J)
     '変数をB(1,1)からB(M,N)に収納させる
   Next J
  Next I
  
'【スラッグ変数の追加】
  For I = 1 To M
  A(I, N + I) = 1  'A(M,N+M)までスラッグ変数を足す
  BS(I) = I + N
  Next I
  For I = 1 To M
   For J = 1 To M
   If I = 1 Then
    B(0, N + J) = 1
    End If
   B(I, N + J) = 1  'B(M,N+M)までスラッグ変数を足す
   Next J
  Next I
  Step = 1: GoSub CellsMatrix '定式化出力
  LOC = 0: DoName = "シンプレックス法無限計算回避"
  
  'ここから繰り返し検索開始
  
  Do
'【新基底変数を検索】
  MinA = 10000000000#: LIN = 0
  For J = 1 To N + M
    If A(0, J) / B(0, J) < MinA Then MinA = A(0, J) / B(0, J): Jma = J
  Next J
  If MinA >= 0 Then Exit Do

'【ピボット行を探す】
  MinA = 10000000000#: Ima = 0
  For I = 1 To M
   If A(I, Jma) * B(I, Jma) <= 0 Then
   TH = 10000000000#
   Else
   TH = A(I, 0) * B(I, Jma) / A(I, Jma) * B(I, 0)
   End If
   If TH < MinA Then MinA = TH: Ima = I
  Next I
  If Ima = 0 Then
  MsgOp = MsgBox(bun2, vbOKOnly, "エラーです"): Exit Do
  End If


'【ピボット中心にタブロー掃出し】
  AA = A(Ima, Jma)    'ピボットを覚えさす
  BB = B(Ima, Jma)
  For J = 0 To M + N
  A(Ima, J) = A(Ima, J) * BB
  B(Ima, J) = B(Ima, J) * AA
  Next J
  For I = 0 To M
   If Not (I = Ima) Then
    AA = A(I, Jma)
    BB = B(I, Jma)
    For J = 0 To M + N
    A(I, J) = A(I, J) * B(Ima, J) * BB - A(Ima, J) * AA * B(I, J)
    B(I, J) = B(I, J) * B(Ima, J) * BB
        '掃き出しの終わった新しい数値を代入
    Next J
   End If
  Next I
'*//
 BS(Ima) = Jma      '基底変数の表示を変える
 Step = Step + 1
 If Step = 3 Then
  bun3 = "STEP 3 以降は上書きして最適解のみを出力します。"
  bun4 = "｢いいえ」の場合は各STEPを出力します。"
  OP1 = MsgBox(bun3 & bun4, vbYesNo, "各STEPの出力ｵﾌﾟｼｮﾝ")
 End If
 
 GoSub CellsMatrix   '定式化出力
  ActiveSheet.Cells(6, 2) = "実行回数は" & Step & "回です" '回数表示
  ActiveSheet.Cells(7, 2) = "最大値は" & A(0, 0) / B(0, 0) & "です" '結果表示
  If LOC > 100 Then bun2 = DoName: GoTo Endmsg
      'ループを防ぐ物だと思われるが、LOCの変数を増やすものが無い？
 Loop

LastMsg:
 bun1 = "ﾌﾟﾛｸﾞﾗﾑの実行が終わったよ。"
 MsgOp = MsgBox(bun1, vbOKOnly, "あいさつ")
 Cells(7, 2).Range("A1").Interior.ColorIndex = 24   '結果部分の色を変える
 Exit Sub
 
'*************************************************
CellsMatrix:        '表の出力
  If Step >= 3 And OP1 = vbYes Then     '表示を二つだけにする
  tate = tate
  Else
  tate = tate + M * 2 + 5: yoko = baseCOL 'tateとyokoを次の表の基本位置へ
  End If
 
  For I = 0 To M
   ActiveSheet.Cells(tate + I * 2 + 1, yoko - 1) = "x(" & BS(I) & ")= "
       '表に基底変数を出力
   ActiveSheet.Cells(tate + I + 1, yoko + 0).Range("A1").Font.ColorIndex = 5
       '定数項部分の色を変える
  For J = 0 To N + M
   If I = 0 Then
   ActiveSheet.Cells(tate + 0, yoko + J) = "x" & J
       '表に変数を出力
   ActiveSheet.Cells(tate + 1, yoko + J).Range("A1").Font.ColorIndex = 3
       'Ｚ行の数値の色を変える
   End If
   ActiveSheet.Cells(tate + I * 2 + 1, yoko + J) = A(I, J)
   ActiveSheet.Cells(tate + I * 2 + 2, yoko + J) = B(I, J)
  Next J, I
  ActiveSheet.Cells(tate + 0, yoko - 1) = Step & "step"
  ActiveSheet.Cells(tate + 1, yoko - 1) = "Ｚ="
  ActiveSheet.Cells(tate + 0, yoko + 0) = "定数項"
  ActiveSheet.Cells(tate + 0, yoko - 1).Interior.ColorIndex = 35
  ActiveSheet.Cells(tate + 1, yoko + 0).Interior.ColorIndex = 36
  ActiveSheet.Cells(tate + 1, yoko + 0).Font.ColorIndex = 56
 Return


Endmsg:
bun1 = "ﾌﾟﾛｸﾞﾗﾑを実行せずに終了します。"
MsgOp = MsgBox(bun1, vbOKOnly, "あいさつ")
End Sub
'