「均等再配置」アドイン

短いコードなので詳しい説明は省きます。

基本的な動作

選択範囲内の行方向に対して相互にセルの値を入れ替えます。
入れ替えた後の最小値が、前の最小値より小さかったら、その最小値を記憶
小さくなかったら、入れ替えを元に戻す

これを繰り返します。
ただし、入れ替えた後に、条件セルの値が０で無い場合は無条件に元に戻す。

以上の処理を収束値に達するか、または、５０回に達するまで繰り返します。

ソースコード

標準モジュール　Optimize

シフト範囲／条件を入力するフォームを起動します。

Sub 均等再配置()
    frm均等再配置.Show '(vbModeless)
End Sub

フォーム　frm均等再配置

Option Explicit

Const 収束判定値 = 0.01

Dim flg中止 As Boolean 'flg中止判定用の変数




Private Sub ref最小化_BeforeDragOver(Cancel As Boolean, ByVal Data As MSForms.DataObject, ByVal x As stdole.OLE_XPOS_CONTAINER, ByVal y As stdole.OLE_YPOS_CONTAINER, ByVal DragState As MSForms.fmDragState, Effect As MSForms.fmDropEffect, ByVal Shift As Integer)

End Sub

Private Sub UserForm_Activate()

    If IsRange("変化させるセル") Then ref範囲 = "変化させるセル"
    If IsRange("最小化セル") Then ref最小化 = "最小化セル"
    If IsRange("条件セル") Then ref条件 = "条件セル"
    
    ref範囲.SetFocus
    
End Sub


Private Sub cmd実行_Click()

    '入力チェック
    
    If Not IsRange(ref範囲) Then
        MsgBox "範囲セルを選択して下さい！", vbOKOnly
        ref範囲.SetFocus
        Exit Sub
    End If
    If Not IsRange(ref最小化) Then
        MsgBox "最小化セルを選択して下さい！", vbOKOnly
        ref最小化.SetFocus
        Exit Sub
    End If
    
    
    flg中止 = False         '「flg中止」フラグをオフ

    cmd中止.Enabled = True  '「flg中止」ボタンを有効
    cmd実行.Enabled = False '「実行」ボタンを無効

    Call 分散最少化(ref範囲, ref条件, ref最小化)
    
    cmd実行.Enabled = True  '「実行」ボタンを有効
    cmd中止.Enabled = False '「flg中止」ボタンを有効
    
    
End Sub


Private Sub cmd中止_Click()  '「中止」ボタンを押された時の処理
    flg中止 = True
End Sub

Sub 分散最少化(範囲セル As String, 条件セル As String, 最小化セル As String)

    '----------------------
    '変数
    '----------------------
    Dim rngShift As Range   '選択範囲
    Dim SigmaSum As Double  '分散計
    
    Set rngShift = Range(範囲セル)
    
    '----------------------
    '開始
    '----------------------

    SigmaSum = 99999    '分散初期値

    '----------------------
    '作業変数
    '----------------------
    
    Dim r, c, r2 As Long
    Dim n As Long
    
    Dim tmpSigmaSum As Double
    
    tmpSigmaSum = SigmaSum
        
    For n = 1 To 10 '繰り返し回数
        

        
        For c = 1 To rngShift.Columns.Count         '選択範囲の列数
            For r = 1 To rngShift.Rows.Count        '選択範囲の行数
                For r2 = r + 1 To rngShift.Rows.Count
                    '-----------------------------
                    DoEvents
                    If flg中止 Then
                        GoTo MyAbort
                    End If
                    '-----------------------------
                    Call MySwap(rngShift(r, c), rngShift(r2, c))   'セル入れ替え
                    
                    If Range(条件セル).Value <> 0 Then              '条件を満たすか？
                        Call MySwap(rngShift(r, c), rngShift(r2, c))   '満たさない→戻す
                    Else
                        Dim tmp
                        tmp = Range(最小化セル).Value   '最小値取り出し
                        If tmp < SigmaSum Then          '値更新？
                            SigmaSum = tmp              '新たな最小値とする
                        Else
                            Call MySwap(rngShift(r, c), rngShift(r2, c))   '戻す
                        End If
                    End If
                Next r2
            Next r
        Next c
        
        If Abs(tmpSigmaSum - SigmaSum) < 収束判定値 Then Exit For '収束
        tmpSigmaSum = SigmaSum
        
    Next n

    '--------------------------------------
    '完了
    '--------------------------------------
    
    GoTo MyEnd

MyAbort:

MyEnd:

    
End Sub


Private Sub MySwap(Rng1 As Range, Rng2 As Range)
    '-----------------
    'セルデータ入替
    '-----------------
    Dim tmp As Variant
    tmp = Rng1.Value
    Rng1.Value = Rng2.Value
    Rng2.Value = tmp
    
End Sub



Private Function IsRange(RangeName As String) As Boolean
' 範囲名の正当性チェック
    On Error GoTo MyEnd
    IsRange = False
    If Range(RangeName).Address <> "" Then IsRange = True
MyEnd:
    On Error GoTo 0
End Function

課題

この処理は簡素化しているため、あまり性能が良いとは言えません。

以下のような改善を加えると、もう少し良くなるかもしれません。

・列方向に順に入れ替えを進めているのを、ランダムな列にする。
・列方向も考慮して、同時に３つ、または、４つのセルを入れ替え試行する。