プロが教えるわが家の防犯対策術!

https://oshiete.goo.ne.jp/qa/8843774.html

で質問してプログラムを組んでくれた方がいましたが
応用できない場面が出てきてしまったので再び質問させて
いただきます。

前回の質問ではすべて3グループに分けられるように
していただきましたが、実はグループ数を固定するのではなく
1グループの人数を3人に固定しなければならなかったのです。

前回回答していただいたVBAのプログラムを編集して
1~12までを3ずつ4グループになるべく重複をしないで
複数回、分けるにはどうしたらいいでしょうか?
できれば複数回分けたところで全部の数が最低1回は同じ
グループに入るようにできると助かります。

今回も1-2-12と1-2-11は重複と考えます。

まったく重複なしで行うのは不可能だということは
わかりますが、できるだけ少ない重複で複数回(今回は最低6回)のグループ分け
を行いたいと思います。

前回のプログラムに説明も付け加えていただきましたが
よく理解できずに今日まできてしまいました。
大変申し訳ありませんがどうかご教授お願いします。

A 回答 (12件中1~10件)

【つづき】



上記で出来上がった表を元に、組合せパターン数の表を作成するもの
#7後半にもありましたが、その表の右側に 1_2_3 の様な表示を追加しています。
#7後半のものでも構いません。

Public Sub CheckPtn()
  Dim dicPtn As Object
  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 vS As Variant, sS As String

  Set dicPtn = CreateObject("Scripting.Dictionary")
  With Range("B2")
    vA = .CurrentRegion.Value
    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
          sS = ""
          For k1 = 0 To iGrp - 2
            sS = sS & "_" & vA(i, j + k1)
            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
          sS = sS & "_" & vA(i, j + k1)
          sS = Mid(sS, 2)
          dicPtn(sS) = dicPtn(sS) + 1
        Next
      End If
    Next
    With .Offset(UBound(vA) + 2)
      .CurrentRegion.Clear
      With .Resize(UBound(vB), UBound(vB))
        .Value = vB
        On Error Resume Next
        .Cells.SpecialCells(xlCellTypeBlanks) _
          .Interior.ColorIndex = 38
        .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
      End With
      
      ReDim vS(1 To dicPtn.Count, 1 To 2)
      i = 1
      For Each v In mySort2(dicPtn.Keys)
        vS(i, 1) = Join(v(1), "_")
        vS(i, 2) = dicPtn(v(0))
        i = i + 1
      Next
      With .Offset(, UBound(vB) + 1)
        .CurrentRegion.Clear
        With .Resize(dicPtn.Count, 2)
          .Value = vS
          .Borders.LineStyle = xlContinuous
        End With
      End With
    End With
  End With
  Set dicPtn = Nothing
End Sub

Private Function mySort2(ByVal vA As Variant) As Variant
  Dim vR As Variant, vS As Variant, v As Variant
  Dim i As Variant, j As Variant, k As Long, n As Long

  ReDim vR(LBound(vA) To UBound(vA))
  For i = LBound(vA) To UBound(vA)
    vS = Split(vA(i), "_")
    For j = 0 To UBound(vS) - 1
      For k = j + 1 To UBound(vS)
        If (Int(vS(j)) > Int(vS(k))) Then
          v = vS(j)
          vS(j) = vS(k)
          vS(k) = v
        End If
      Next
    Next
    vR(i) = Array(vA(i), vS)
  Next
  For i = LBound(vR) To UBound(vR) - 1
    For j = i + 1 To UBound(vR)
      For k = 0 To UBound(vS)
        If (Int(vR(i)(1)(k)) < Int(vR(j)(1)(k))) Then
          n = 0
          Exit For
        ElseIf (Int(vR(i)(1)(k)) > Int(vR(j)(1)(k))) Then
          n = 1
          Exit For
        End If
      Next
      If (n > 0) Then
        v = vR(i)
        vR(i) = vR(j)
        vR(j) = v
      End If
    Next
  Next
  mySort2 = vR
End Function

※ mySort2 は、文字列で与えられたものを1度バラして・・・ってやってます
(元々数値の表側を見ればもっと少ない記述になりますが)
「重複しないグループ分けについて」の回答画像12
    • good
    • 1
この回答へのお礼

長いソースをかいていただいて本当にありがとうございました。

動かしてみましたが、とても早く動いてあっという間に表が出来上がるので素晴らしい内容だと思いました。

あとは目的に応じてちょっと手直しするだけなので、大変助かりました。

長い期間いろいろ考えていただいてありがとうございました。

4分割のうち最後のものにベストアンサーをつけさせていただきます。

また困ったときには知恵を貸してください。よろしくお願いします。

お礼日時:2015/04/01 17:44

【つづき】



ここは基本的に重複のないパターンを作成するものになります。
iPos が 1 なら素直に重複のないパターンを求めますが、
PtnNext で作られた残りの部分を作ることもします。

Private Sub PtnMake(iA() As Long, ByVal iPos As Long)
  Dim jPos As Long, iAs() As Long
  Dim vP As Variant
  Dim sS As String
  Dim i As Long, j As Long, k As Long, n As Long

  If (iPos = iNum) Then
    Call PtnAdd(iA)
    Exit Sub
  End If

  ReDim vP(1 To iNum)
  ReDim iAs(1 To iNum)
  vP(1) = iAs
  For i = 1 To iPos - 1
    iAs(iA(i)) = -1
  Next
  vP(iPos) = iAs
  jPos = iPos + 1
  iA(jPos) = -1

  Do While ((jPos > iPos) And (jPos <= iNum))
    If (Timer() - st > CPROCTIME * 60) Then
      bBrake = True
      Exit Do
    End If
    If (iA(jPos) < 0) Then
      If ((jPos Mod CGRPNUM) = 1) Then
        ReDim iAs(1 To iNum)
        For i = 1 To jPos - 1
          iAs(iA(i)) = -1
        Next
        j = 1
      Else
        iAs = vP(jPos - 1)
        j = iA(jPos - 1)
        For k = j + 1 To iNum
          If (iSmtx(j, k) > 0) Then iAs(k) = -1
        Next
        j = j + 1
      End If
      vP(jPos) = iAs
    Else
      iAs = vP(jPos)
      j = iA(jPos) + 1
    End If

    For i = j To iNum
      If (iAs(i) = 0) Then Exit For
    Next

    If (i <= iNum) Then
      iA(jPos) = i
      If ((jPos Mod CGRPNUM) = 0) Then
        sS = ""
        For j = jPos - CGRPNUM + 1 To jPos
          sS = sS & CSEP & iA(j)
        Next
        If (Not dicP.Exists(Mid(sS, Len(CSEP) + 1))) Then
          If (jPos = iNum) Then
            Call PtnAdd(iA)
            If (iPos > 1) Then Exit Do
            jPos = iPos + 1
          Else
            jPos = jPos + 1
          End If
          iA(jPos) = -1
        Else
          jPos = jPos - 1
        End If
      Else
        jPos = jPos + 1
        iA(jPos) = -1
      End If
    ElseIf (jPos = iNum) Then
      jPos = jPos - CGRPNUM
    Else
      jPos = jPos - 1
    End If
  Loop
End Sub

【つづく】
    • good
    • 0
この回答へのお礼

ありがとうございます。

お礼日時:2015/04/01 17:40

【つづき】



ここが使っていないパターンを組み合わせて作っていく部分
★ 部分は、使っていない組み合わせはグループ数の半分程度にしておきましょうか・・・という事にしています。
この部分のありなしとか、判別条件とかで組合せ数が結構変わってきます。
(ない場合よりは、この判別で結構バラケてくれた)
1グループ3人をメインに確認していたので、4人・5人等では違うやり方が良いのかも?

▲ 部分は、グループ人数に満たない使っていないパターンを、
既存のパターンのどれと組み合わせていくのか・・・という判別になりますが、
1番多いものと組み合わせることをしています。
ここでの < を、<= > >= に変える事でもパターンは変わってきます。

Private Function PtnNext(iA() As Long, iPos As Long) As Boolean
  Dim dicN As Object, dicU As Object, dicE As Object
  Dim vE As Variant, vS As Variant, v As Variant, vW As Variant
  Dim i As Long, j As Long, k As Long, n As Long
  Dim idp As Long

  vE = Array()
  vS = Array()
  Set dicN = CreateObject("Scripting.Dictionary")
  Set dicU = CreateObject("Scripting.Dictionary")
  Set dicE = CreateObject("Scripting.Dictionary")
  For i = 1 To iNum
    dicN(i) = Empty
  Next
  Do While (dicN.Count > 0)
    dicE.RemoveAll
    v = mySort(dicN.Keys)
    n = v(UBound(v))
    dicN.Remove n
    For i = 1 To n - 1
      If (Not dicU.Exists(i)) Then
        If (iMmtx(i, n) = 0) Then dicE(i) = Empty
      End If
    Next
    If (dicE.Count >= CGRPNUM - 1) Then
      While (dicE.Count <> CGRPNUM - 1)
        v = dicE.Keys
        dicE.Remove v(1)
      Wend
      dicE(n) = Empty
      ReDim Preserve vE(UBound(vE) + 1)
      vE(UBound(vE)) = mySort(dicE.Keys)
      For Each v In dicE.Keys
        If (dicN.Exists(v)) Then dicN.Remove v
        dicU(v) = Empty
      Next
      If (UBound(vE) >= (iNum \ CGRPNUM) \ 2) Then Exit Do ' ★
    ElseIf (dicE.Count > 0) Then
      dicE(n) = Empty
      ReDim Preserve vS(UBound(vS) + 1)
      vS(UBound(vS)) = mySort(dicE.Keys)
      For Each v In dicE.Keys
        If (dicN.Exists(v)) Then dicN.Remove v
      Next
    End If
  Loop

  PtnNext = False
  If ((UBound(vE) < 0) And (UBound(vS) < 0)) Then Exit Function

  PtnNext = True
  dicE.RemoveAll
  For i = 0 To UBound(vS)
    For j = 0 To UBound(vS(i))
      dicE(vS(i)(j)) = Empty
    Next
    For Each v In dicU.Keys
      If (dicE.Exists(v)) Then dicE.Remove v
    Next
    If (dicE.Count >= CGRPNUM) Then
      While (dicE.Count <> CGRPNUM)
        v = mySort(dicE.Keys)
        dicE.Remove v(1)
      Wend
      v = mySort(dicE.Keys)
      If (Not dicP.Exists(Join(v, CSEP))) Then
        ReDim Preserve vE(UBound(vE) + 1)
        vE(UBound(vE)) = v
        For j = 0 To UBound(v)
          dicU(v(j)) = Empty
        Next
      End If
      dicE.RemoveAll
    End If
  Next

  If (dicE.Count > 1) Then
    vS = Empty
    dicN.RemoveAll
    For i = 1 To iNum
      If (Not dicU.Exists(i)) Then dicN(i) = Empty
    Next
    idp = 0
    vW = dicN.Keys
    For i = 0 To UBound(vW)
      dicE(vW(i)) = Empty
      If (dicE.Count = CGRPNUM) Then
        v = mySort(dicE.Keys)
        If (Not dicP.Exists(Join(v, CSEP))) Then
          n = 0
          For j = 0 To UBound(v) - 1
            For k = j + 1 To UBound(v)
              n = n + iMmtx(v(j), v(k))
            Next
          Next
          If (idp < n) Then ' ▲
            idp = n
            vS = v
          End If
        End If
        dicE.Remove vW(i)
      End If
    Next
    If (Not IsEmpty(vS)) Then
      ReDim Preserve vE(UBound(vE) + 1)
      vE(UBound(vE)) = vS
    End If
  End If

  k = 0
  For Each v In vE
    For i = 0 To UBound(v)
      k = k + 1
      iA(k) = v(i)
    Next
  Next
  iPos = k

  Set dicN = Nothing
  Set dicU = Nothing
  Set dicE = Nothing
End Function

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

  For i = LBound(vA) To UBound(vA) - 1
    For j = i + 1 To UBound(vA)
      If (vA(i) > vA(j)) Then
        v = vA(i)
        vA(i) = vA(j)
        vA(j) = v
      End If
    Next
  Next
  mySort = vA
End Function

【つづく】
    • good
    • 1
この回答へのお礼

ありがとうございます。

お礼日時:2015/04/01 17:40

#8です



#8画像からチョッと変わりましたが・・・

力技的な処理かもしれないので、参考程度にしてください
4分割での回答になります(3分割では無理でした)

動かしてみた感想でも頂ければと思います。

★★ 部分で、組合せ状況を表示するものを呼び出しています
#7後半にもありましたが、その表の右側に 1_2_3 の様な表示を追加しています。
#7後半のものでも構いません。


Option Explicit

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

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

Public Sub Samp3()
  Dim iA() As Long, iPos As Long
  Dim v As Variant
  Dim i As Long, j As Long, k As Long

  v = InputBox(CGRPNUM & "の倍数を入力すると、" _
        & CGRPNUM & "人ずつのグループに", , CGRPNUM ^ 2)
  iNum = (Val(v) \ CGRPNUM) * CGRPNUM
  If (iNum <= CGRPNUM) Then Exit Sub
  MsgBox iNum & " 人で処理します" _
      & "(時間リミットは" & CPROCTIME & "分)"

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

  ReDim iMmtx(1 To iNum, 1 To iNum)
  iSmtx = iMmtx
  ReDim iA(1 To iNum)
  For i = 1 To iNum
    iA(i) = i
  Next

  bBrake = False
  st = Timer()
  Call PtnAdd(iA)
  Call PtnMake(iA, 1)
  ReDim v(1 To iNum)
  v(1) = "-"
  i = dic.Count
  dic(i) = v

  While (PtnNext(iA, iPos) And (Not bBrake))
    ReDim iSmtx(1 To iNum, 1 To iNum)
    i = dic.Count
    While ((dic.Count = i) And (iPos > 0))
      Call PtnMake(iA, iPos)
      iPos = iPos - CGRPNUM
    Wend
  Wend

  Cells.Clear
  With Range("B2")
    With .Resize(, iNum)
      For i = 1 To iNum Step CGRPNUM
        With .Cells(i).Resize(, CGRPNUM)
          .Merge
          .Value = "Grp" & (i \ CGRPNUM) + 1
        End With
      Next
      i = 1
      For Each v In dic.Items
        .Offset(i) = v
        i = i + 1
      Next
    End With
    With .CurrentRegion
      .Borders.LineStyle = xlContinuous
      .HorizontalAlignment = xlCenter
    End With
  End With
  Call CheckPtn ' ★★
  Columns.AutoFit

  If (bBrake) Then MsgBox "時間切れ(途中まで)"

  Set dic = Nothing
  Set dicP = Nothing
End Sub

Private Sub PtnAdd(iA() As Long)
  Dim sS As String
  Dim iB() As Long
  Dim i As Long, j As Long, k As Long, n As Long
  Dim iR As Long, iC As Long

  iB = iA
  For i = 1 To iNum - CGRPNUM Step CGRPNUM
    For j = i + CGRPNUM To iNum Step CGRPNUM
      If (iB(i) > iB(j)) Then
        For k = 0 To CGRPNUM - 1
          n = iB(i + k)
          iB(i + k) = iB(j + k)
          iB(j + k) = n
        Next
      End If
    Next
  Next

  For i = 0 To iNum \ CGRPNUM - 1
    sS = ""
    n = i * CGRPNUM
    For j = 1 To CGRPNUM - 1
      sS = sS & CSEP & iB(n + j)
      For k = j + 1 To CGRPNUM
        iR = iB(n + j)
        iC = iB(n + k)
        iMmtx(iR, iC) = iMmtx(iR, iC) + 1
        iSmtx(iR, iC) = iSmtx(iR, iC) + 1
      Next
    Next
    sS = sS & CSEP & iB(n + j)
    dicP(Mid(sS, Len(CSEP) + 1)) = Empty
  Next
  i = dic.Count
  dic(i) = iB
End Sub

【つづく】
    • good
    • 1
この回答へのお礼

ありがとうございます。

お礼日時:2015/04/01 17:39

#7です



待っていなかったのかも知れませんが、お待たせしました。

処理全部、見直しました。
それにより、1グループ3人で 18人分けまで即座に応答があります。
(画像添付)
21人~ は、2分では終わらない・・・
1グループ xx 人でも、ソコソコ動けるかもしれません。
前回までは、変更しやすいような雰囲気がありましたが、実際は・・・??
今回は、xx 人でもソコソコいけるかも

※ 一応、そのコードを載せたいと思いますが、必要ならという事にします。
(コードが長くなったので、3回に分かれると思います)
回答しなくても、ブログの記事として週末辺りには公開したいと思っています。


添付した画像では、1グループ3人の18人なら・・・

※ 出来たからと言って、吟味できてないものは投稿しない方が良いですね
(反省しきりです)
ま、回答での真偽は問わない・・・
これがあるので、気楽に回答出来ているわけですけど・・・
「重複しないグループ分けについて」の回答画像8
    • good
    • 0
この回答へのお礼

続けて考えていただいて誠にありがとうございます。

せっかくですので、可能であればコードを載せていただけると助かります。
今後の参考にさせていただきたいと思います。

お礼日時:2015/03/31 22:33

【つづき】



Private Sub dicPost(dic As Object, dicN As Object, iA() As Long)
  Static dicC As Object, dicW As Object
  Dim i As Long, j As Long, k As Long, n As Long
  Dim vA As Variant, vB As Variant
  Dim v As Variant
  Dim iCnt As Long

  If (dic.Count = 0) Then
    Set dicC = CreateObject("Scripting.Dictionary")
    Set dicW = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(iA) \ CGRPNUM
      dicC.Add i, CreateObject("Scripting.Dictionary")
      dicW.Add i, CreateObject("Scripting.Dictionary")
    Next
  End If

  ReDim vA(1 To UBound(iA) \ CGRPNUM)
  ReDim vB(1 To CGRPNUM)
  n = 1
  For i = 1 To UBound(vA)
    vA(i) = vB
    For j = 1 To CGRPNUM
      vA(i)(j) = iA(n)
      n = n + 1
    Next
    For j = 1 To CGRPNUM - 1
      For k = j + 1 To CGRPNUM
        If (vA(i)(j) > vA(i)(k)) Then
          v = vA(i)(j)
          vA(i)(j) = vA(i)(k)
          vA(i)(k) = v
        End If
      Next
    Next
  Next
  For i = 1 To UBound(vA) - 1
    For j = i + 1 To UBound(vA)
      If (vA(i)(1) > vA(j)(1)) Then
        v = vA(i)
        vA(i) = vA(j)
        vA(j) = v
      End If
    Next
  Next

  For i = 1 To UBound(vA)
    dicW(i).RemoveAll
    For j = 1 To CGRPNUM - 1
      For k = 1 To CGRPNUM
        If (j <> k) Then
          dicN(vA(i)(j))(vA(i)(k)) = Empty
          If (j < k) Then
            dicW(i)(vA(i)(j) & "_" & vA(i)(k)) = Empty
          End If
        End If
      Next
    Next
    For k = 1 To CGRPNUM
      dicN(vA(i)(j))(vA(i)(k)) = Empty
    Next
  Next

  iCnt = 0
  For i = 1 To UBound(vA)
    If (dicC.Exists(Join(vA(i), "_"))) Then Exit Sub
    For Each v In dicW(i).Keys
      If (dicC(i).Exists(v)) Then
        If (dic.Count \ 3 < dicC(i)(v)) Then Exit Sub ' ☆
        iCnt = iCnt + 1
      End If
    Next
  Next

  Debug.Print "iCnt ="; iCnt
  If (iCnt <= UBound(vA) + CALWCNT) Then
    Debug.Print ">Ok iCnt ="; iCnt
    vB = iA
    n = 1
    For i = 1 To UBound(vA)
      dicC(Join(vA(i), "_")) = Empty
      For Each v In dicW(i).Keys
        dicC(i)(v) = dicC(i)(v) + 1
      Next
      For j = 1 To CGRPNUM
        vB(n) = vA(i)(j)
        n = n + 1
      Next
    Next
    i = dic.Count
    dic(i) = vB
  End If
End Sub

Public Sub CheckPtn()
  Dim vA As Variant, vB As Variant
  Dim i As Long, j As Long, k1 As Long, k2 As Long
  Dim iGrp As Long

  With Range("B2")
    vA = .CurrentRegion.Value
    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) + 2)
      .CurrentRegion.Clear
      With .Resize(UBound(vB), UBound(vB))
        .Value = vB
        On Error Resume Next
        .Cells.SpecialCells(xlCellTypeBlanks) _
          .Interior.ColorIndex = 38
        .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
      End With
    End With
  End With
End Sub
    • good
    • 0

#5です



では、現状でのコードになりますが Samp1 をベースにしているので、それより遅くなります。
重複の無い組合せと、重複をチョッと入れてみた組合せ表示は - で区切ってます。
表内の数字を入れ替え後に、CheckPtn 実行で個数がわかります。
1基準の昇順で組合せを見ていくので、
数字自体をランダムにしたい場合は ★ ~ ~ ★を有効にするとそれッポク
重複の調整は、☆ 部分と、CALWCNT でやってみましたが、裏付けある方法ではありません。
☆ 部分は、同じグループ内に同じパターンがいくつ出現して良いか・・・を雰囲気で
CALWCNT は、重複したパターンいくつまで許可するか・・・を雰囲気で
この辺いじって、いろいろ動きを見てください。
今回この Samp2 / dicPost では、組合せを作る / チェックする、を分離した下手な処理にしてしまったので、チェックしながら作る様に変更すれば速くなりそうな感触があります(嘘かも)
頭の中で処理が浮かんだら試してみようかと思っています。
すぐに閉じないでいてもらえれば、結果の報告が出来るかも??(期待はしないでください)
Samp1 をベースにしていたので、9~15はそれなりに表示されますが、
18~は2分では終わりません。
18人の場合(私のPCでは)
2分リミットで4組、5分リミットで5組の重複なしが得られましたけど・・・

以下、参考程度で


Option Explicit

Const CGRPNUM As Long = 3 ' 1グループの人数
Const CPROCTIME As Long = 2 ' 処理リミット(分)
Const CALWCNT As Long = 2 ' 重複許可数(グループ数+α の α ≧ 0 )

Public Sub Samp2()
  Dim dic As Object, dicN As Object
  Dim iA() As Long, iB() As Long, v As Variant
  Dim vA As Variant, vN As Variant
  Dim iNum As Long, iPos As Long
  Dim i As Long, j As Long, k As Long
  Dim iSp As Long
  Dim st As Single

  Set dic = CreateObject("Scripting.Dictionary") ' 結果格納用
  Set dicN = CreateObject("Scripting.Dictionary") ' 数値重複管理用途

  v = InputBox(CGRPNUM & "の倍数を入力すると、" _
        & CGRPNUM & "人ずつのグループに", , CGRPNUM ^ 2)
  iNum = (Val(v) \ CGRPNUM) * CGRPNUM
  If (iNum <= 0) Then Exit Sub
  MsgBox iNum & " 人で処理します(時間リミットは" & CPROCTIME & "分)"
  st = Timer()

  ReDim iA(1 To iNum)
  ReDim iB(1 To iNum)
  ReDim vA(1 To iNum)
  ReDim vN(1 To iNum)
  For i = 1 To iNum
    vN(i) = 1
  Next
  vA(1) = vN
  iA(1) = 1
  For i = 1 To iNum
    dicN.Add i, CreateObject("Scripting.Dictionary")
    iB(i) = i
  Next
'' ★ ~
'  Randomize
'  For i = 1 To iNum
'    j = Int(iNum * Rnd()) + 1
'    k = Int(iNum * Rnd()) + 1
'    v = iB(j)
'    iB(j) = iB(k)
'    iB(k) = v
'  Next
'' ~ ★

  iPos = 1
  While (iPos > 0)
    iPos = 1
    While ((iPos > 0) And (iPos <= iNum))
      iSp = 1
      If ((iPos Mod CGRPNUM) = 1) Then
        vN = vA(1)
        If (iPos = 1) Then
          iSp = iA(1)
        Else
          For i = 1 To iPos - 1
            vN(iA(i)) = 0
          Next
          vA(iPos) = vN
        End If
      Else
        vN = vA(iPos - 1)
        i = iA(iPos - 1)
        vN(i) = 0
        For Each v In dicN(i).Keys
          vN(v) = 0
        Next
        vA(iPos) = vN
      End If
      For i = iSp To iNum
        If (vN(i) > 0) Then Exit For
      Next

      If (i <= iNum) Then
        iA(iPos) = i
        iPos = iPos + 1
      Else
        i = (iPos \ CGRPNUM) * CGRPNUM
        If (i = 0) Then
          iPos = 2
        Else
          iPos = i
        End If
        Do While (iPos > 0)
          If (iPos = 1) Then
            For Each v In dicN.Keys
              dicN(v).RemoveAll
            Next
            If (iA(1) = 1) Then
              ReDim v(1 To iNum)
              v(1) = "-"
              i = dic.Count
              dic(i) = v
            End If
          End If
          vN = vA(iPos)
          For i = iA(iPos) + 1 To iNum
            If (vN(i) > 0) Then
              iA(iPos) = i
              iPos = iPos + 1
              Exit For
            End If
          Next
          If (i <= iNum) Then Exit Do
          iPos = iPos - 1
        Loop
      End If
      If (Timer() - st > CPROCTIME * 60) Then iPos = 0 ' 分のリミット
    Wend
    If (iPos > iNum) Then Call dicPost(dic, dicN, iA)
  Wend

  Cells.Clear
  With Range("B2")
    With .Resize(, iNum)
      For i = 1 To iNum Step CGRPNUM
        With .Cells(i).Resize(, CGRPNUM)
          .Merge
          .Value = "Grp" & (i \ CGRPNUM) + 1
        End With
      Next
    End With
    i = 1
    For Each v In dic.Items
      If (Val(v(1)) > 0) Then
        For j = 1 To iNum
          v(j) = iB(v(j))
        Next
      End If
      .Offset(i).Resize(, iNum) = v
      i = i + 1
    Next
    With .CurrentRegion
      .Borders.LineStyle = xlContinuous
      .HorizontalAlignment = xlCenter
    End With
  End With
  Call CheckPtn
  Columns.AutoFit

  Set dic = Nothing
  Set dicN = Nothing
End Sub

【つづく】
    • good
    • 0

#3です



ソコソコ動く?ものは出来ましたが

> 「各数字で他の数字と最低1回は同じグループに入る」というのを重視

を、どう解釈して良いのか迷っています
先に提示した Samp1 は、1基準の昇順で組合せを求めてみるものになってました。
1度出現を確定させると、それに重ならない様に求めていくものになってました。
なので、どの程度のものを確定させるかで以降のパターンが変わってきます。
今回のは、15人の場合以下の様な結果が得られるのですが

1-2-3、4-5-6、7-8-9、10-11-12、13-14-15
1-4-7、2-5-8、3-10-13、6-11-14、9-12-15
1-5-9、2-4-10、3-6-15、7-11-13、8-12-14
1-6-8、2-7-14、3-9-11、4-12-13、5-10-15
1-10-14、2-11-15、3-4-8、5-7-12、6-9-13
- 上記が重複しない組み合わせ(下が重複をチョッと入れてみて)
1-7-14、2-9-11、3-12-13、4-10-15、5-6-8
1-11-15、2-3-8、4-7-12、5-9-13、6-10-14
1-3-9、2-5-15、4-8-11、6-10-13、7-12-14
1-10-15、2-3-7、4-6-12、5-8-13、9-11-14
1-2-13、3-4-5、6-7-8、9-10-11、12-14-15
1-6-14、2-8-10、3-11-12、4-9-15、5-7-13

1-12
2-6、2-12
3-14
4-14
5-11、5-14
7-10、7-15
8-15

が出てきていません。12人の場合は、

1-6
2-6
3-4、3-5
4-11
7-10
8-10
9-11

が出てきていません。
これら出現しないものが無いように・・・という事だったでしょうか?

現状のコードは提示できますが、文字数の関係で分割になります。
(雰囲気でしか考えていないので、考え方がおかしいかも)
    • good
    • 0
この回答へのお礼

出てこなかった部分で、例えば15人の場合、1-12にもう一つ適当な数字を加えて1-12-2(12は2-12もないようなので)というグループを作って、7回目の組み分けができればベストだと考えています。
そうすれば各数が最低1回は同じグループに入るような組み合わせができると思います。

かなりプログラムがややこしい感じになりそうなのは伝わってきますので、#3さんのように出てこない組み合わせを別なセルに書き出すようなものでもかまいません。

重複をちょっと入れたものの形でプログラムの文を載せていただけると助かります。

12、15、18の場合でプログラムのどの部分を変更すればいいのかがわかるとなお助かります。

何度も申し訳ありませんがよろしくお願いします。

お礼日時:2015/03/28 01:44

#1,#2の回答者です。



どうやら、結果がはっきりしました。結論から言うと、ダメだったというだけなのですが、私がどこかで間違ったのか、それとも、もともと、無理だったのか、それはわかりません。何度か検証してみましたが、8行程度しか、出力できませんでした。期待させて、申し訳なかったと思っています。

私の再検証の話は、結果が出ていない以上は詳しくは不要だと思いますが、一応、言い訳だけ残しておきます。この項目の最後に、組合せ(Combination)のアルゴリズムを置いておきます。このアルゴリズムは、私が、かなり古くから持っていたものです。

「12行を出すというなら、1 ~12 各々の数は、平均個数4となります。
それぞれの個数の平均4に近づけています。」(平均化フィルタ)

>「各数字で他の数字と最低1回は同じグループに入る」
これに関しては、ほぼ9割は、確保できます。

「数字の2組のずつ、重複の組合せを探し、あったら、その抽出行の組合せは使わないとする。ちなみに、1~18を6つずつの全行に重複しない場合は、2つの数字の15組の検査が必要になります。」(縦の重複フィルタ)

(私は、「1~18を6つずつ[×4行の]3グループ」という場合、12行を通してと解釈しています。4行ずつ、各々の重複のないグループ別けなら可能かとは思います。グループ各々は「縦の重複」は存在しませんが、3グループないし4グループでは、発生してしまいます。)

という具合の2つの「フィルタ」を通した結果が、行数が足らず不満足な形に終わってしまった、ということです。バグらしきものが見つからないので、設計自体に問題があるのか、それとも、もともと解が見つからないのか、それさえわかりません。

今回、もっとも大事な部分を公開しておきます。これをベースに、マクロで取り出すようにしました。

「組合せ」のアルゴリズム
'//
Const n_TOTAL = 9 'Numbers of total -全数
Const r_PICK = 6 'Numbers of extraction-抜き取り数
'-----------------------
Sub MakingCombin()
Dim Stock() As Long
Dim i As Long
ReDim Stock(0)
'cells clear
'Start from A1
Range("A1").CurrentRegion.ClearContents
For i = 1 To n_TOTAL
 ReDim Preserve Stock(i - 1)
 Stock(i - 1) = i
Next i
Call sCombinations(Stock, r_PICK)
End Sub
Public Sub sCombinations(ByRef Stock() As Long, ByVal r As Long)
  Dim num As Long
  Dim ar As Variant
  Dim i As Long, j As Long
  Dim k As Long
  num = UBound(Stock) - LBound(Stock)
  r = r - 1
  ReDim ar(0, r)
  Dim idx() As Long
  ReDim idx(0 To r)
  For i = 0 To r
    idx(i) = i
  Next i

  Do
    For j = 0 To r
       ar(0, j) = Stock(idx(j))
    Next j
     k = k + 1
     Cells(k, 1).Resize(, r_PICK).Value = ar
    i = r
    While (idx(i) = num - r + i)
      i = i - 1
      If i = -1 Then
        Exit Sub
      End If
    Wend
    idx(i) = idx(i) + 1
    For j = i + 1 To r
      idx(j) = idx(i) + j - i
    Next j
  Loop
End Sub
    • good
    • 0
この回答へのお礼

長い間考えていただいて誠にありがとうございました。
12を3つずつ4グループを複数回繰り返してすべて重複を避けることができるのは3回までという結論に至ったので、できるだけ少ない重複(1回ないし2回)で4回、5回・・・とできるようなプログラムができればと考えていました。

もし、上記のようなプログラムができれば載せていただけるとありがたいです。

無茶な要求に一生懸命応えていただけたことをとても感謝しています。
また何かあればご教授願えればと思います。

お礼日時:2015/03/28 01:32

重複なしのものをベタで求めてみました。


ソコソコ良さそうな雰囲気(あくまで雰囲気)です。
(全パターンでは無い様な気も)

9 ~ 15 は、ソコソコすぐに結果が出ます。
18 ~ は、かなり時間がかかる様で、2分のリミットを。
2分経っても終わらなかったら、そこまで出来ていたものを表示して終わり

なお、表示されるパターン数は6つになっていないので、
出来上がったものを適当に入れ替えれば良いかも?
ってダメでしょうか?


Public Sub Samp1()
  Dim dic As Object, dicN As Object
  Dim iA() As Long, v As Variant
  Dim vA As Variant, vN As Variant
  Dim iNum As Long, iPos As Long
  Dim i As Long, j As Long, k As Long
  Dim st As Single
  Const CGRPNUM As Long = 3 ' 1グループの人数

  Set dic = CreateObject("Scripting.Dictionary") ' 結果格納用
  Set dicN = CreateObject("Scripting.Dictionary") ' 数値重複管理用途

  v = InputBox("3の倍数を入力すると、3人ずつのグループに", , 9)
  iNum = (Val(v) \ CGRPNUM) * CGRPNUM
  If (iNum <= 0) Then Exit Sub
  MsgBox iNum & " 人で処理します(時間リミットは2分)"
  st = Timer()

  For i = 1 To iNum
    dicN.Add i, CreateObject("Scripting.Dictionary")
  Next
  ReDim iA(1 To iNum)
  ReDim vA(1 To iNum)
  ReDim vN(1 To iNum)
  For i = 1 To iNum
    vN(i) = 1
  Next
  vA(1) = vN

  iPos = 1
  While (iPos > 0)
    iPos = 1
    While ((iPos > 0) And (iPos <= iNum))
      If ((iPos Mod CGRPNUM) = 1) Then
        vN = vA(1)
        If (iPos <> 1) Then
          For i = 1 To iPos - 1
            vN(iA(i)) = 0
          Next
          vA(iPos) = vN
        End If
      Else
        vN = vA(iPos - 1)
        i = iA(iPos - 1)
        vN(i) = 0
        For Each v In dicN(i).Keys
          vN(v) = 0
        Next
        vA(iPos) = vN
      End If
      For i = 1 To iNum
        If (vN(i) > 0) Then Exit For
      Next

      If (i <= iNum) Then
        iA(iPos) = i
        iPos = iPos + 1
      Else
        iPos = iPos - 1
        Do While (iPos > 1)
          vN = vA(iPos)
          For i = iA(iPos) + 1 To iNum
            If (vN(i) > 0) Then
              iA(iPos) = i
              iPos = iPos + 1
              Exit For
            End If
          Next
          If (i <= iNum) Then Exit Do
          iPos = iPos - 1
        Loop
        If (iPos = 1) Then iPos = 0
      End If
      If (Timer() - st > 120) Then iPos = 0 ' 2分のリミット
    Wend
    If (iPos > iNum) Then
      For i = 0 To (iNum - 1) \ CGRPNUM
        For j = 1 To CGRPNUM
          For k = 1 To CGRPNUM
            If (j <> k) Then
              dicN(iA(i * CGRPNUM + j))(iA(i * CGRPNUM + k)) = Empty
            End If
          Next
        Next
      Next
      i = dic.Count
      dic(i) = iA
    End If
  Wend

  Cells.Clear
  With Range("B3")
    For i = 1 To iNum \ CGRPNUM
      With .Offset(-1, (i - 1) * CGRPNUM).Resize(, CGRPNUM)
        .Merge
        .Value = "Grp" & i
        .HorizontalAlignment = xlCenter
      End With
    Next
    i = 0
    For Each v In dic.Items
      .Offset(i).Resize(, iNum) = v
      i = i + 1
    Next
    .CurrentRegion.Borders.LineStyle = xlContinuous
  End With
  Columns.AutoFit

  Set dic = Nothing
  Set dicN = Nothing
End Sub
    • good
    • 0
この回答へのお礼

プログラムを組んでいただいてありがとうございます。
起動させてみましたが重複するものは表示されなくなるようですね。
わがままで申し訳ないですが、「各数字で他の数字と最低1回は同じグループに入る」というのを重視していただけると助かりますが・・・。

長いプログラムの文章を書いてくださって本当にありがとうございました。

お礼日時:2015/03/25 15:32

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています