FC2ブログ

スポンサーサイト 


上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

Excel VBA をやってみた その15 


もう広告表示になったのね
記事として遅れていた分を緊急に・・・という事で


副題:重複しないグループ分けについて

重複しないグループ分けについて に回答したもの+α のものになります。
内容的には、
12人、15人の人で、1グループ3人の組合せを作る。
この時、1回以上違う人と組む。
15人の場合、1番の人なら、2番~15番の人と1回以上組む
というもの。

回答した、Samp1 / Samp2 / Samp3 は、重複しない組み合わせを求めて
Samp2 はソコソコに、Samp3 は一応全部組んでみよう・・・というもの
基本的な考え方は、以下の図の様な感じ

kEnt212.jpg

で、15人の場合を求めた結果は、左:Samp1、中:Samp2、右:Samp3
Samp1 / Samp2 は、人同士の組み合わせを Dictionary で管理
Samp3 は、人数 x 人数 の配列で管理

kEnt212_1.jpg  kEnt212_2.jpg  kEnt212_3.jpg

Samp1 / Samp2 / Samp3 では、重複しないものを1度求める事をしていたため、
人数が多くなればなるほど遅くなっていくので、
どうせ重複しないと全部求められないので、人数 x 人数の配列を綺麗に埋めていけば・・・
埋める際、何個使った・・・は、配列で管理して・・・埋め方を考えれば良いんでしょう・・・
※ この埋める時のやり方は、現状力任せになっています

Samp4 は単に、求めたパターンを管理する方法を変えてみただけの確認用
確認用の処理は、重複しない組み合わせが基本ですが、前に戻って求め直す事はしない。

kEnt212_4.jpg

Samp5 は、1グループ3人に限定して、処理パターンを4つ
人数 x 人数 の配列は、右上半分だけ使用・・・というのは
1グループに、1-2-3 番を作ったとした場合、配列(1,2)、配列(1,3)、配列(2,3) 部分を更新
この配列を更新して、使っていない部分がなくなるまで処理を続ける・・・・

処理1:配列(1,2) ~ (1,人数)、(2,3) ~ (2,人数) と探す
  使っていないものがあったら、その位置を確定して
  例えば、(x,y) が使っていなければ、残りの1つ z を
  z < x なら (z,x)、z < y なら (z,y)
  z > x なら (x,z)、z > y なら (y,z)
  この値を加算して1番小さかった z を残りの1つとして確定
処理2:探す順は処理1と同じだが、
  配列(1,2) ~ (1,人数) で使っていなものを探して、使っていないもの同士も使っていないものを優先
  例えば、(1,5)、(1,7)、(1,9)、(1,10)、(1,12) が使っていなかった場合
  (5,7)(5,9)(5,10)(5,12)(7,9)(7,10)(7,12)(9,10)(9,12)(10,12) の順で使っていないものを探す
処理3:配列(1,人数) ~ (人数-1,人数)、(1,人数-1) ~ (人数-2,人数-1) と探す
  残りの1つ z は同じようにして
処理4:処理2の処理3バージョン

パターンを求めていく中で、使える数字内で使っていないものが無かったら・・・
例えば、1 が使える場合
(1,2) ~ (1,人数) まで使える数字部分を眺めて、1番小さかったものを使う
1 以外に 6、9 が使えた場合、(1,6)、(1,9) の値の小さい 6 or 9 を選んでいく・・・

※ 残っていくもの同士の組合せについては、グループとして重複しない様にしているだけなので、
もっと数学的な選び方があると思いますが・・・力任せで・・・

以下は各処理で、左:15人、90人(中:31パターン目、右:結果)
「中:」の画像では、確定したパターンは赤もどきの色、確定候補が水色

処理1
kEnt212_5_1.jpg  kEnt212_5_1A.jpg  kEnt212_5_1B.jpg

処理2
kEnt212_5_2.jpg  kEnt212_5_2A.jpg  kEnt212_5_2B.jpg

処理3
kEnt212_5_3.jpg  kEnt212_5_3A.jpg  kEnt212_5_3B.jpg

処理4
kEnt212_5_40.jpg  kEnt212_5_4A.jpg  kEnt212_5_4B.jpg
 
Samp1 / Samp2 / Samp3 / Samp4 については、サンプルファイル内の記述を参照ください。
(ここにそのまま記述すると長くなるので割愛)

Samp3 について補足しておくと、
人数 x 人数 の配列は2つ持ってます。
1つはトータル的な情報として、もう1つはパターン生成時に使う情報として。
重複ないパターンを求める時には内容は同じ。
重複を許す場合は、パターン生成用をクリアにしてから・・・・
これは、パターン生成の同じ処理を走らせたかったから・・・


Samp5

詳しくは説明しないので、サンプルファイルを動かしてみてください。

今わかっているのは、81人、処理2・・・完結しません
人数が(12人とか15人位)少なければ、処理1/処理2??
人数が多くなれば、処理4???
ただ、どの様なパターンが欲しいのかによっては・・・
・求めたパターン数が少なければ良いのか???
・パターン数は多いけど、各人が重複する回数が少ない方が良いのか???

結構な人数でもソコソコ求められているとは思いますが、力任せのやり方なので、
数学的な求め方を調べた方が良さそう・・・!!!
グループのパターン(例えば3人だったら)を決めていく時、
残った人の重複パターンがどのように変化するかを考えてみる???
結構処理時間がかかりそう・・・
厳密に求めたいのなら、やり方を調べてから・・・・作りなおした方が・・・良いですね・・・
どこか、参考になる所でもあればという事で・・・・

処理の過程を色付けで見えるようにしているので、
人数/処理パターンを変更しながら・・・確かめてみてください。

Option Explicit

' 1グループの人数(3人限定バージョン)
Const CPROCTIME As Long = 2 ' 処理リミット(分)
Const CSEP As String = "_" ' 数値結合文字

Dim dic As Object, dicP As Object
Dim iMtx() As Long
Dim iNum As Long
Dim st As Single
Dim bBrake As Boolean

Public Sub Samp5()
  Dim v As Variant
  Dim i As Long, j As Long, k As Long, n As Long
  Dim iSel As Long
  Dim bNext As Boolean

  v = InputBox("3の倍数を入力すると、3人ずつのグループに", , 12)
  iNum = (Val(v) \ 3) * 3
  If (iNum <= 3) Then Exit Sub
  v = iNum & " 人で処理します(時間リミットは" & CPROCTIME & "分)" & vbCrLf
  v = v & "処理パターンを 1 or 2 or 3 or 4 で選択してください" & vbCrLf & vbCrLf
  v = v & " 1 or 2 : 左上から右に" & vbCrLf
  v = v & " 3 or 4 : 右上から下に" & vbCrLf & vbCrLf
  v = v & "※ 人数によっては完成しないことも・・・"
  v = InputBox(v, , 1)
  iSel = Val(v)
  For Each v In Array(1, 2, 3, 4)
    If (iSel = v) Then Exit For
  Next
  If (IsEmpty(v)) Then Exit Sub

  Set dic = CreateObject("Scripting.Dictionary")
  Set dicP = CreateObject("Scripting.Dictionary")

  ReDim iMtx(1 To iNum, 1 To iNum)

  Worksheets.Add After:=ActiveSheet
  With Range("A1").Resize(iNum, iNum) ' ★ 処理経過表示用
    If (iNum < 50) Then
      .EntireColumn.ColumnWidth = 1.88
    Else
      .Font.Size = 6
      .EntireColumn.ColumnWidth = 0.7
      .EntireRow.RowHeight = 6
    End If
  End With

  bBrake = False
  st = Timer()

  Call PtnMake(iSel)

  Cells.Clear
  With Range("A2").Offset(, 4)
    With .Resize(, iNum)
      For i = 1 To iNum Step 3
        With .Cells(i).Resize(, 3)
          .Merge
          .Value = "Grp" & (i \ 3) + 1
        End With
      Next
      i = 0
      For Each v In dic.Items
        i = i + 1
        .Offset(i) = v
      Next
      With .Offset(1).Resize(i)
        .Sort Key1:=.Cells(1), Key2:=.Cells(2), Key3:=.Cells(3), Header:=xlNo
      End With
    End With
    With .CurrentRegion
      .Borders.LineStyle = xlContinuous
      .Columns(1).Borders(xlEdgeLeft).Weight = xlMedium
      For i = 3 To iNum Step 3
        .Columns(i).Borders(xlEdgeRight).Weight = xlMedium
      Next
      .HorizontalAlignment = xlCenter
    End With
  End With
  Call CheckPtn5(iSel)
  Columns.AutoFit
  Rows.AutoFit

  MsgBox Timer() - st & " 秒"
  If (bBrake) Then MsgBox "時間切れ(途中まで)"

  Set dic = Nothing
  Set dicP = Nothing
End Sub

Private Sub PtnColor(vP As Variant, iC As Long)
  Dim i As Long, j As Long

  For i = 1 To 2
    For j = i + 1 To 3
      Cells(vP(i), vP(j)).Interior.ColorIndex = iC
    Next
  Next
End Sub

Private Sub PtnMake(iSel As Long)
  Dim iA() As Long, iB() As Long
  Dim vG As Variant, vP As Variant
  Dim iG() As Long, IR As Long
  Dim i As Long, j As Long
  Dim bContinue As Boolean

  ReDim vG(1 To iNum \ 3)
  ReDim iG(1 To iNum \ 3)
  ReDim iB(1 To iNum)
  IR = 1
  Do While ((IR > 0) And (Not bBrake))
    If (Timer() - st > CPROCTIME * 60) Then
      bBrake = True
      Exit Do
    End If
    vP = vG(IR)
    ReDim iA(1 To iNum)
    For i = 1 To IR - 1
      For j = 1 To 3
        iA(vG(i)(j)) = -1
      Next
    Next
    If (Not IsEmpty(vP)) Then
      Call PtnColor(vP, xlNone) ' ★ やり直しで色なしに
      For i = 1 To 2
        For j = i + 1 To 3
          If (iMtx(vP(i), vP(j)) = 0) Then
            If (i = 1) Then
              iB(vP(5 - j)) = -1
            Else
              i = 3
            End If
            Exit For
          End If
        Next
        If (j <= 3) Then Exit For
      Next
      If (i > 2) Then iB(vP(1)) = -1
      For i = 1 To iNum
        iA(i) = iA(i) + iB(i)
      Next
    End If
    bContinue = True
    iG(IR) = VH_PtnMake(iSel, iA, vP) ' 未割当探し
    If (iG(IR) < 0) Then
      bContinue = False
      If (IR > 1) Then
        iG(IR) = VH_PtnMake(99, iA, vP) ' 重複間のパターン探し
        If (iG(IR) >= 0) Then
          bContinue = True
        Else
          IR = IR - 1
        End If
      Else
        Exit Do
      End If
    End If
    If (bContinue) Then
      If (Not dicP.Exists(Join(vP, CSEP))) Then ' 1グループ内の重複チェック
        Call PtnColor(vP, 28) ' ★ 候補に色付け
        vG(IR) = vP
        IR = IR + 1
        If (IR = UBound(vG) + 1) Then
          Call PtnAdd(vG) ' 確定
          IR = 1
          ReDim iB(1 To iNum)
        End If
        vG(IR) = Empty
      Else
        iB(vP(1)) = -1
        IR = IR - 1
      End If
    End If
  Loop
End Sub

Private Function GetPtn(iSel As Long, iA() As Long _
              , vW As Variant) As Long
  Dim vA As Variant
  Dim i As Long, j As Long, k As Long
  Dim iGap As Long
  Const CGAPVAL As Long = 999999

  GetPtn = 0
  Select Case iSel
    Case 1
        For i = 1 To iNum - 1
          If (iA(i) = 0) Then
            For j = i + 1 To iNum
              If (iA(j) = 0) Then
                If (iMtx(i, j) = 0) Then
                  vW(1) = i
                  vW(2) = j
                  GetPtn = 2
                  Exit Function
                End If
              End If
            Next
          End If
        Next
    Case 3
        For i = iNum To 2 Step -1
          If (iA(i) = 0) Then
            For j = 1 To i - 1
              If (iA(j) = 0) Then
                If (iMtx(j, i) = 0) Then
                  vW(1) = j
                  vW(2) = i
                  GetPtn = 2
                  Exit Function
                End If
              End If
            Next
          End If
        Next
    Case 2
        vW(1) = 0
        For i = 1 To iNum - 1
          If (iA(i) = 0) Then
            vA = Array()
            For j = i + 1 To iNum
              If (iA(j) = 0) Then
                If (iMtx(i, j) = 0) Then
                  ReDim Preserve vA(UBound(vA) + 1)
                  vA(UBound(vA)) = j
                End If
              End If
            Next
            If (UBound(vA) >= 0) Then
              For j = 0 To UBound(vA) - 1
                For k = j + 1 To UBound(vA)
                  If (iMtx(vA(j), vA(k)) = 0) Then
                    vW(1) = i
                    vW(2) = vA(j)
                    vW(3) = vA(k)
                    GetPtn = 3
                    Exit Function
                  End If
                Next
              Next
              If (vW(1) = 0) Then
                vW(1) = i
                vW(2) = vA(0)
              End If
            End If
          End If
        Next
        GetPtn = IIf(vW(1) = 0, 0, 2)
    Case 4
        vW(1) = 0
        For i = iNum To 2 Step -1
          If (iA(i) = 0) Then
            vA = Array()
            For j = 1 To i - 1
              If (iA(j) = 0) Then
                If (iMtx(j, i) = 0) Then
                  ReDim Preserve vA(UBound(vA) + 1)
                  vA(UBound(vA)) = j
                End If
              End If
            Next
            If (UBound(vA) >= 0) Then
              For j = 0 To UBound(vA) - 1
                For k = j + 1 To UBound(vA)
                  If (iMtx(vA(j), vA(k)) = 0) Then
                    vW(1) = vA(j)
                    vW(2) = vA(k)
                    vW(3) = i
                    GetPtn = 3
                    Exit Function
                  End If
                Next
              Next
              If (vW(1) = 0) Then
                vW(1) = vA(0)
                vW(2) = i
              End If
            End If
          End If
        Next
        GetPtn = IIf(vW(1) = 0, 0, 2)
    Case 99
        iGap = CGAPVAL
        For i = 1 To iNum - 1
          If (iA(i) = 0) Then
            For j = i + 1 To iNum
              If (iA(j) = 0) Then
                If (iGap > iMtx(i, j)) Then
                  iGap = iMtx(i, j)
                  vW(1) = i
                  vW(2) = j
                End If
              End If
            Next
            Exit For
          End If
        Next
        GetPtn = IIf(iGap <> CGAPVAL, 2, 0)
  End Select
End Function

Private Function VH_PtnMake(iSel As Long, iA() As Long, vP As Variant) As Long
  Dim vW As Variant
  Dim i As Long, j As Long, k As Long
  Dim iGap As Long, v As Variant
  Const CGAPVAL As Long = 999999

  ReDim vW(1 To 3)
  VH_PtnMake = -1
  Select Case GetPtn(iSel, iA, vW)
    Case 2
      iGap = CGAPVAL
      For i = iNum To 1 Step -1
        If ((iA(i) = 0) And (i <> vW(1)) And (i <> vW(2))) Then
          k = 0
          For Each v In Array(vW(1), vW(2))
            If (i < v) Then
              k = k + iMtx(i, v)
            Else
              k = k + iMtx(v, i)
            End If
          Next
          If (k = 0) Then
            vW(3) = i
            iGap = 0
            Exit For
          ElseIf (iGap > k) Then
            iGap = k
            vW(3) = i
          End If
        End If
      Next
      If (iGap = CGAPVAL) Then Exit Function
    Case 3
      iGap = 0
    Case Else
      Exit Function
  End Select
  vP = mySort(vW)
  VH_PtnMake = iGap
End Function

Private Sub PtnAdd(vG As Variant)
  Dim vA As Variant, v As Variant
  Dim iA() As Long
  Dim i As Long, j As Long, k As Long, n As Long

  vA = mySort(vG)
  ReDim iA(1 To iNum)
  n = 1
  For i = 1 To UBound(vA)
    v = vA(i)
    Call PtnColor(v, 26) ' ★ 確定色に
    dicP(Join(v, CSEP)) = Empty
    For j = LBound(v) To UBound(v)
      iA(n) = v(j)
      n = n + 1
      For k = j + 1 To UBound(v)
        iMtx(v(j), v(k)) = iMtx(v(j), v(k)) + 1
        Cells(v(j), v(k)).Value = iMtx(v(j), v(k)) ' ★ 割当数の表示
      Next
    Next
  Next

  i = dic.Count
  dic(i) = iA
End Sub

Private Function mySort(ByVal vA As Variant) As Variant
  Dim vB As Variant, v As Variant
  Dim i As Long, j As Long, k As Long

  If (IsArray(vA(LBound(vA)))) Then
    For k = LBound(vA) To UBound(vA)
      vB = vA(k)
      GoSub COMPROC
      vA(k) = vB
    Next
    k = LBound(vB)
    For i = LBound(vA) To UBound(vA) - 1
      For j = i + 1 To UBound(vA)
        If (vA(i)(k) > vA(j)(k)) Then
          v = vA(i)
          vA(i) = vA(j)
          vA(j) = v
        End If
      Next
    Next
    mySort = vA
  Else
    vB = vA
    GoSub COMPROC
    mySort = vB
  End If
  Exit Function

COMPROC:
  For i = LBound(vB) To UBound(vB) - 1
    For j = i + 1 To UBound(vB)
      If (vB(i) > vB(j)) Then
        v = vB(i)
        vB(i) = vB(j)
        vB(j) = v
      End If
    Next
  Next
  Return
End Function

Private Sub CheckPtn5(iSel As Long)
  Dim rng As Range, r As Range
  Dim vA As Variant, vB As Variant, v As Variant
  Dim i As Long, j As Long, k1 As Long, k2 As Long
  Dim iGrp As Long
  Dim sS As String

  With Range("A2")
    With .Offset(, 4)
      With .CurrentRegion
        vA = .Value
        Set rng = .Offset(1).Resize(.Rows.Count - 1)
      End With
      iGrp = .Cells(1).MergeArea.Count
      ReDim vB(1 To UBound(vA, 2) + 1, 1 To UBound(vA, 2) + 1)
      vB(1, 1) = "組"
      For i = 2 To UBound(vB)
        vB(1, i) = i - 1
        vB(i, 1) = i - 1
        vB(i, i) = "A"
      Next
      For i = 2 To UBound(vA)
        If (Val(vA(i, 1)) > 0) Then
          For j = 1 To UBound(vA, 2) Step iGrp
            For k1 = 0 To iGrp - 2
              For k2 = k1 + 1 To iGrp - 1
                vB(vA(i, j + k1) + 1, vA(i, j + k2) + 1) = _
                  vB(vA(i, j + k1) + 1, vA(i, j + k2) + 1) + 1
                vB(vA(i, j + k2) + 1, vA(i, j + k1) + 1) = _
                  vB(vA(i, j + k2) + 1, vA(i, j + k1) + 1) + 1
              Next
            Next
          Next
        End If
      Next
      With .Offset(UBound(vA) + 1, -1)
        With .Resize(UBound(vB), UBound(vB))
          .Value = vB
          On Error Resume Next
          .Cells.SpecialCells(xlCellTypeBlanks) _
            .Interior.ColorIndex = 38
          On Error GoTo 0
          .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1) _
            .SpecialCells(xlCellTypeConstants _
                    , xlTextValues).ClearContents
          .Columns(1).Interior.ColorIndex = 36
          .Rows(1).Interior.ColorIndex = 36
          .Borders.LineStyle = xlContinuous
          .HorizontalAlignment = xlCenter
          .EntireColumn.AutoFit
          sS = .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1) _
              .Address(False, False)
        End With
      End With
    End With

    With .Resize(, 3)
      .Cells(1).Value = "処理 " & iSel
      .Cells(2).Value = iNum & "人" ' 人数
      .Cells(3).Value = UBound(vA) - 1 & "行" ' パターン数
      .HorizontalAlignment = xlRight
    End With
    .Offset(1).Value = "最大"
    .Offset(1, 1).Formula = "=MAX(" & sS & ")"
    With .Offset(1, 2)
      .Formula = "=IF(COUNTIF(" & sS & ","""")=" & iNum & ",""OK"",""NG"")"
      With .FormatConditions.Add(xlCellValue, xlEqual, "=""OK""")
        .Interior.ColorIndex = 34
      End With
      With .FormatConditions.Add(xlCellValue, xlEqual, "=""NG""")
        .Interior.ColorIndex = 38
      End With
      .HorizontalAlignment = xlCenter
    End With
    For i = 1 To 10
      .Offset(i + 1).Value = i
      .Offset(i + 1, 1).Formula = "=COUNTIF(" & sS & "," & i & ")/2"
    Next
  End With
End Sub



サンプルは以下
 バージョン 2000 でも
 ファイル kEnt212.zip
 サイズ 173,479
※ ファイルは zip 形式
※ 2007 で作成した Excel ファイル(互換:xls)
※ 2007 で作成した Excel ファイル(xlsm) の2つが入っています

関連記事

2015/04/11

Category: やってみる

TB: --  /  CM: 0

top △

この記事に対するコメント

top △

コメントの投稿

Secret

top △


上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。