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

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

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

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

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

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

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

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

このQ&Aに関連する最新のQ&A

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に関連する人気のQ&A

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

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

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

Q重複しないグループ分けをエクセルで

excel2010を使用しています。

1~9までを3つずつ3グループに分ける作業を4回行い、4回とも重複しないようにしたいのですが、エクセルの関数でうまく重複を避ける方法があるのでしょうか?

        Aグループ Bグループ Cグループ
1回目    1-2-3  4-5-6  7-8-9
2回目    1-4-7  2-5-8  3-6-9
3回目    ・・・
4回目    ・・・

のようにすべての回で重複しないようにしたいと思っています。
9つを3つずつ・・・は手書きでもなんとかなると思いますが
1~12を4つずつ3グループに重複しないで・・・
1~15を5つずつ3グループに重複しないで・・・
1~18を6つずつ3グループに重複しないで・・・
というように応用したいと思いますので、ぜひエクセルの関数かVBAのプログラムで作成できるようにしたいと思っていますが、どのような関数をどのように使えばいいのかわからず困っています。


どなたかご教授いただけないでしょうか。
  

Aベストアンサー

1~9なら重複なし、12なら重複1まで、15なら重複2まで、…24なら重複6までOKとして作ってみました。
並び替えに乱数を使っている手抜き版ですが、取りあえず動きます。
数値をB2セル以降に入れています。

コードが長くなったのとあまりに手抜きで恥ずかしいので、細かい説明は省略します。

Public nGroupData()
Public nRow As Integer
Sub test()
  Dim nTarget()
  Dim nMax As Long
  Dim nCount
  ReDim nGroupData(11)
  
  nRow = 1
  '対象配列を作成
  nMax = 9 '3で割り切れる数(9~24)。9以外にする場合はここを変更
  ReDim nTarget(nMax - 1)
  For i = 0 To (nMax - 1)
    nTarget(i) = i + 1
  Next i
  
  nCount = 0
  Do While nRow <= 4
    '配列をシャッフル
    nTarget = fShuffle(nTarget)
    
    '配列に重複が無いか確認
    If fChkTarget(nTarget) = True Then
      '重複なしならシート上に反映
      nTarget = fSortTarget(nTarget)
      For i = 0 To (nMax - 1)
        Cells(nRow + 1, i + 2) = nTarget(i)
      Next i
      nRow = nRow + 1
    Else
      nCount = nCount + 1
      '乱数に頼っているので1000回やっても重複なしにならなかったらGiveUp
      If nCount >= 1000 Then
        MsgBox ("GiveUP!")
        Exit Sub
      End If
    End If
  Loop
End Sub

' 配列をシャッフル
Private Function fShuffle(list)
  For i = 0 To UBound(list)
    Randomize Second(Now())
    nRn = Int(UBound(list) * Rnd)
    nTmp = list(i)
    list(i) = list(nRn)
    list(nRn) = nTmp
  Next i
  fShuffle = list
End Function

'グループ内でソート
Private Function fSortTarget(nTarget)
  Dim nGroup
  Dim nGrCount As Long
  Dim nWork(2)
  nGrCount = (UBound(nTarget) + 1) / 3
  For i = 0 To 2
    nSwap = 1000
    Do While nSwap <> 0
      nSwap = 0
      For j = (i * nGrCount) To ((i + 1) * nGrCount - 2) Step 2
        If nTarget(j) > nTarget(j + 1) Then
          nSwap = nTarget(j)
          nTarget(j) = nTarget(j + 1)
          nTarget(j + 1) = nSwap
        End If
      Next j
      For j = (i * nGrCount + 1) To ((i + 1) * nGrCount - 2) Step 2
        If nTarget(j) > nTarget(j + 1) Then
          nSwap = nTarget(j)
          nTarget(j) = nTarget(j + 1)
          nTarget(j + 1) = nSwap
        End If
      Next j
    Loop
    nGroup = 0
  Next i
  fSortTarget = nTarget
    
End Function

'重複をチェック
Private Function fChkTarget(nTarget) As Boolean
  Dim nWorkOne
  Dim nGrCount As Long
  Dim nWork(2), nChk, sChk
  fChkTarget = False
  
  nGrCount = (UBound(nTarget) + 1) / 3
  For i = 0 To 2
    nWorkOne = 0
    For j = 1 To nGrCount
       nWorkOne = nWorkOne + 2 ^ (nTarget(i * nGrCount + j - 1) - 1)
    Next j
    
    '重複していない個数を確認
    For k = 0 To ((nRow - 1) * 3 - 1)
      '検査対象と、今までのグループのデータでxorを取る
      nChk = (nWorkOne Xor nGroupData(k))
      sChk = fDec2Bin(nChk) '01の2進数文字列(24文字)に変換
      sChk = Replace(sChk, "0", "") '「0」を削除
      '1の個数=比較して重複していない個数
      '1の個数が規定より少なければ重複と判断
      If Len(sChk) < nGrCount Then Exit Function
    Next k
    nWork(i) = nWorkOne
  Next i
  For i = 0 To 2
    nGroupData(3 * (nRow - 1) + i) = nWork(i)
  Next i
  fChkTarget = True
End Function

'10進数を2進数のStringに変換
Private Function fDec2Bin(nData) As String
  '10進数を2進数のStringに変換(Max2^24)
  Dim nDataInt(2), i
  Dim sAns As String
  
  nDataInt(0) = Int(nData / (65536))
  nDataInt(1) = Int((nData Mod 65536) / 256)
  nDataInt(2) = nData Mod 256
  For i = 0 To 2
    sAns = sAns & Application.WorksheetFunction.Dec2Bin(nDataInt(i), 8)
  Next i
  fDec2Bin = sAns
End Function

1~9なら重複なし、12なら重複1まで、15なら重複2まで、…24なら重複6までOKとして作ってみました。
並び替えに乱数を使っている手抜き版ですが、取りあえず動きます。
数値をB2セル以降に入れています。

コードが長くなったのとあまりに手抜きで恥ずかしいので、細かい説明は省略します。

Public nGroupData()
Public nRow As Integer
Sub test()
  Dim nTarget()
  Dim nMax As Long
  Dim nCount
  ReDim nGroupData(11)
  
  nRow = 1
  '対象配列を作成
  nMax = 9 '3で割り切れる数(9~24...続きを読む

Q50人を数回、グループ分けする方法について。

グループ分けの方法について質問させて頂きます。

50人を7つのグループに分ける方法についてです。
人数は、7人グループ6つ、8人グループ一つです。

このグループ分けを5回行いますが、毎回、それぞれが
出来る限り同じグループになったことのない人とあたるように分けたいのですが・・・

何かうまい方法はないでしょうか。
よろしくお願い致します。

Aベストアンサー

   1,2,3,4,5,6,7、
   1,2,3,4,5,6,7、
   1,2,3,4,5,6,7、
   1,2,3,4,5,6,7、
   1,2,3,4,5,6,7、
   1,2,3,4,5,6,7、
   1,2,3,4,5,6,7、

   1,2,3,4,5,6,7、
   7、1,2,3,4,5,6、
   6,7、1,2,3,4,5,
   5,6,7、1,2,3,4,


49人でやってるけど

縦に7人でやる  横に1つづらして 縦に7人

横に7人  縦にずらして  横に7人

これで4回分

QExcelでの全通りの組み合わせ出力方法(文字列)

Excelについて全くの初心者で、教えて頂きたい質問があります。

Excelの文字列の全通りの組み合わせを出力がしたいのですが、その方法が分かりません。
例えばセルAに
・りんご
・みかん
・いちご

セルBに
・だいこん
・キャベツ
・トマト

があり、別のセルにその全通りの組み合わせを出力
(文字と文字の間はスペース)

りんご だいこん
りんご キャベツ
りんご トマト
みかん だいこん
みかん キャベツ
みかん トマト
いちご だいこん
いちご キャベツ
いちご トマト

この様に出来る方法はあるでしょうか?
また出来ればその裏(だいこん りんご)も出力したいと考えており、キーワードは3つまで出来るようになりたいです。

どなたかご存じでしたら、ぜひお教え下さい。
よろしくお願いします。

Aベストアンサー

A列B列は1行目からデータがあるものとします。
C列に転記するものとします。

以下の手順をおためしください。

1.Altキー+F11キーでVisualBasicEditorを呼び出します。

2.メニューから挿入、標準モジュールで出てきたコードウィンド(右側の白い広い部分)に以下のコードをコピペします。

Sub test01()
a = Cells(Rows.Count, "A").End(xlUp).Row 'A列最終行取得
b = Cells(Rows.Count, "B").End(xlUp).Row 'B列最終行取得
For i = 1 To a '1行からA列最終行まで繰り返し
For n = 1 To b '1行からB列最終行まで繰り返し
x = x + 1
Cells(x, "C") = Cells(i, "A") & " " & Cells(n, "B") 'C列に結合して転記
Next n
Next i
End Sub

3.Alt+F11キーでワークシートへもどります.

4.メニューから、ツール、マクロ、マクロで出てきたマクロ名(test01)を選択して実行

これでできます。
これがわかれば「裏」というのも簡単ですよね。
以上はVBAでの回答ですが、外していたらごめんなさい。

A列B列は1行目からデータがあるものとします。
C列に転記するものとします。

以下の手順をおためしください。

1.Altキー+F11キーでVisualBasicEditorを呼び出します。

2.メニューから挿入、標準モジュールで出てきたコードウィンド(右側の白い広い部分)に以下のコードをコピペします。

Sub test01()
a = Cells(Rows.Count, "A").End(xlUp).Row 'A列最終行取得
b = Cells(Rows.Count, "B").End(xlUp).Row 'B列最終行取得
For i = 1 To a '1行からA列最終行まで繰り返し
For n = 1 To b '1行...続きを読む

QExcelですべての組合せ(重複組合せ)を出力するには?

Excelですべての組合せ(重複組合せ)を出力するには?

次の条件のような場合、Excelですべての組合せ(重複組合せ)をVBAで出力するにはどうしたらいいのでしょうか?

10種類のお菓子の中から、好きなものを3個選んでセットにするとします。
同じものを複数選ぶのはありですが「菓子A、菓子B、菓子C」と「菓子B、菓子C、菓子A」は選んだ順が違うだけで同じ組合せなので、どちらか片方だけにします。

この場合、すべての組合せの数は Excelの関数で求めることができるようで COMBIN(10+3-1,3) = 220 通りあることまではわかりましたが、このすべての組合せの一覧をどのようにして出力したらいいのかがわかりません。

いろいろ検索した結果、順列という方法は見つかりましたが、重複組合せでの方法は見つけることができませんでした。
また、Accessを使っても似たようなことができるのでしょうか? 直積?

できれば、3個固定ではなく5個の場合も出来るとうれしいです。
よろしくお願いします。

Aベストアンサー

>同じものを複数選ぶのはありですが「菓子A、菓子B、菓子C」と「菓子B、菓子C、菓
つまり「菓子A、菓子A、菓子A」も「菓子A、菓子A、菓子B」もあり ですね。
№2さんのコードをお借りして
Sub Test()
  Dim myStr As Variant
  Dim rowX As Long
  Dim i As Long, j As Long, k As Long
  Const MaxNum = 10

  myStr = Split("A B C D E F G H I J")
  rowX = 1
  For i = 0 To MaxNum - 1
    For j = i To MaxNum - 1
      For k = j To MaxNum - 1
        Cells(rowX, 1).Value = myStr(i)
        Cells(rowX, 2).Value = myStr(j)
        Cells(rowX, 3).Value = myStr(k)
        rowX = rowX + 1
      Next k
    Next j
  Next i
End Sub

>同じものを複数選ぶのはありですが「菓子A、菓子B、菓子C」と「菓子B、菓子C、菓
つまり「菓子A、菓子A、菓子A」も「菓子A、菓子A、菓子B」もあり ですね。
№2さんのコードをお借りして
Sub Test()
  Dim myStr As Variant
  Dim rowX As Long
  Dim i As Long, j As Long, k As Long
  Const MaxNum = 10

  myStr = Split("A B C D E F G H I J")
  rowX = 1
  For i = 0 To MaxNum - 1
    For j = i To MaxNum - 1
      For k = j To MaxNum - 1
       ...続きを読む

Qエクセルで公平にチーム分けする方法を教えて下さい

20人のメンバーを2チームに分け毎週スポーツの練習をしています。毎回公平にチームメンバーが入れ替わる様にエクセルで設定してチーム分けのメンバー表を作りたいのですが、ご存じの方教えてください。

Aベストアンサー

他の方もご指摘されていますように、「公平」の意味がよく分かりませんが
「同じ組み合わせが無いように」という理解で考えてみました。
乱数を使用する方法では、低確率ですが同じ組み合わせが発生し得ます。

※以下Excel2007以降のバージョンでやって下さい。

メンバー20名の名前を横にA1セル~T1セルへ入力します。
[F11]キーを押して、左上のプロジェクトエクスプローラーからSheet1(Sheet1)を
Wクリックします。
右側のエディタエリアに以下のコードを貼り付けます。

Sub sample()
rIdx = 1
For i1 = 1 To 20
For i2 = i1 + 1 To 20
For i3 = i2 + 1 To 20
For i4 = i3 + 1 To 20
For i5 = i4 + 1 To 20
For i6 = i5 + 1 To 20
For i7 = i6 + 1 To 20
For i8 = i7 + 1 To 20
For i9 = i8 + 1 To 20
For i10 = i9 + 1 To 20
rIdx = rIdx + 1
Cells(rIdx, i1).Value = "A"
Cells(rIdx, i2).Value = "A"
Cells(rIdx, i3).Value = "A"
Cells(rIdx, i4).Value = "A"
Cells(rIdx, i5).Value = "A"
Cells(rIdx, i6).Value = "A"
Cells(rIdx, i7).Value = "A"
Cells(rIdx, i8).Value = "A"
Cells(rIdx, i9).Value = "A"
Cells(rIdx, i10).Value = "A"
For i = 1 To 20
If Cells(rIdx, i).Value <> "A" Then Cells(rIdx, i).Value = "B"
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
MsgBox ("終了しました")
End Sub

[F5]を押して実行します。
お使いのPCの能力にもよりますが、終わるまでに数分かかります。

この結果が『20名をA・Bチームに分ける全ての組み合わせ』です。
これを上から順にやれば重複無くチーム分けを行えます。

ただ、実際問題として、全ての組み合わせは18万4756通りあり、全ての
組み合わせを試すには1日1通りならば500年以上かかることになりますが。

他の方もご指摘されていますように、「公平」の意味がよく分かりませんが
「同じ組み合わせが無いように」という理解で考えてみました。
乱数を使用する方法では、低確率ですが同じ組み合わせが発生し得ます。

※以下Excel2007以降のバージョンでやって下さい。

メンバー20名の名前を横にA1セル~T1セルへ入力します。
[F11]キーを押して、左上のプロジェクトエクスプローラーからSheet1(Sheet1)を
Wクリックします。
右側のエディタエリアに以下のコードを貼り付けます。

Sub sample()
rIdx = 1
For i1 = 1...続きを読む

QExcelでデータ全通り組み合わせ出力方法

Excelでデータ全通り組み合わせ出力方法について教えて頂けますと助かります。

セルA~Eに、数がまちまちのアイテム名が入っています。
(セルA~Eというのは例で、変則的に全てのアイテム数は増減します。)

全ての組合せをセルG~Kに各々書き出してくれる方法はあるでしょうか?
(イメージ添付あり)

できればセルに入力すれば自動的に組合せが追加されていくのが理想です。
Excel2010を使用しており、VBAは初心者です。


どなたかご存じでしたら、ぜひお教え下さい。
よろしくお願いします。

Aベストアンサー

#1、2、cjです。#1、2、補足欄へのレスです。

取り急ぎ、コードのみ修正しました。
#2を元に書き換えています。

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rSrc As Range
  Application.EnableEvents = False
  Set rSrc = Range("B2").CurrentRegion
  Application.EnableEvents = True
  If Intersect(Target, rSrc) Is Nothing Then Exit Sub
  Application.EnableEvents = False
  Call PrintCombi(rSrc)
  Application.EnableEvents = True
End Sub

Sub PrintCombi(ByVal rSrc As Range)
  Dim tnFld As Long
  Dim nRc As Long
  Dim nConti As Long
  Dim nRow As Long
  Dim i As Long
  Dim j As Long

  tnFld = rSrc.Columns.Count
  nConti = 1
  With rSrc(1, rSrc.Columns.Count + 3)
    .CurrentRegion.Clear
    Cells(1).Resize(, tnFld).Copy .Cells(1)
    For i = tnFld To 1 Step -1
      nRc = Cells(Rows.Count, i).End(xlUp).Row
      nRow = 2
      For j = 2 To nRc
        Cells(j, i).Copy Destination:=.Cells(nRow, i).Resize(nConti)
        nRow = nRow + nConti
      Next j
      nConti = nConti * (nRc - 1)
    Next i
    With .Cells(2, 1).Resize(nConti)
      For i = 2 To tnFld
        Range(.Cells(1, i), .Cells(.Cells.Count + 1, i).End(xlUp)).Copy Destination:=.Columns(i)
      Next i
    End With
  End With
End Sub

#1、2、cjです。#1、2、補足欄へのレスです。

取り急ぎ、コードのみ修正しました。
#2を元に書き換えています。

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rSrc As Range
  Application.EnableEvents = False
  Set rSrc = Range("B2").CurrentRegion
  Application.EnableEvents = True
  If Intersect(Target, rSrc) Is Nothing Then Exit Sub
  Application.EnableEvents = False
  Call PrintCombi(rSrc)
  Application.EnableEvents = True
...続きを読む

Q10人を2人づつ5組にランダムに分けて表示したい。

AからJまでの10人を1組2人づつに分ける組み合わせは
COMBIN(10,2)+COMBIN(8,2)+COMBIN(6,2)+COMBIN(4,2)=94通り
と思われますが、これら94の組み合わせの中から、任意の1つをランダムに表示出来るようにしたい、できればEXCEL(関数またはマクロ)で。
よろしくお願いいたします。

Aベストアンサー

>ランダムな順に10人をピックアップ」も人手ではなくパソコンでやって
>ほしいのです。

他の方の回答も含めて、そのつもりで回答されていると思いますけれど、何を人手でやるおつもりなのでしょうか?
マクロでやるならその通りの処理をOpenイベントで実行すればできますし、関数利用でも別に難しいことではありません。

関数の場合の一例を、説明した手順通りに分解して表示するなら…
A1~J1に対象となる名前があるとして
A2に =RAND()               :順番のもとになる乱数
A3に =RANK(A2,$A2:$J2)        :乱数を元に順番付け
A4に =MATCH(COLUMN(),$A3:$J3,0) :順に並べた時の対称の列番号
A5に =INDEX($A1:$J1,A4)        :乱数の順に並べ替えた名前
を入力して、A2~A5を選択して、右にコピーフィル。
5行目に乱数順に並べ替えた名前が表示されます。
(組み合わせは先頭から2人ずつ)

計算の手順がわかるように、1行ずつに途中経過を表示していますが、実際は途中を省略できますので、あとは適当にアレンジしてください。

(注意)Rankを使用しているので、乱数値がたまたままったく同じ値だとうまくいきませんが、RANDは実数になるので、そのようなことが起こる確率は非常に少ないと考えてよいとしています。

>ランダムな順に10人をピックアップ」も人手ではなくパソコンでやって
>ほしいのです。

他の方の回答も含めて、そのつもりで回答されていると思いますけれど、何を人手でやるおつもりなのでしょうか?
マクロでやるならその通りの処理をOpenイベントで実行すればできますし、関数利用でも別に難しいことではありません。

関数の場合の一例を、説明した手順通りに分解して表示するなら…
A1~J1に対象となる名前があるとして
A2に =RAND()               :順番のもとになる乱数
A...続きを読む

Qエクセル メンバー表からグループメンバーを抽出

縦に名前が並び、その横の列に男女、その横の列にA・B・Cの3グループが入力されている表があります。
その表からAグループ・Bグループ・Cグループのメンバーを抽出して各グループのメンバー表を作成したいです。

条件として…
(1)今後メンバーが増える可能性がある。
(2)メンバーの所属グループは変更になる。
(3)グループの人数構成はバラバラである。
(4)メンバー表の名前は上から縦に並べたい。
(5)メンバー表はそれぞれ別シートに作成したい。
(6)ABどちらかに所属する男性のみ(女性のみ)のグループのメンバー表も作成したい。

毎日作成するので日々の手間を最小限にしたいです。
関数等を利用して一発で表作成することはできないでしょうか?

よろしくお願いします。

Aベストアンサー

関数案については、既に回答が出ていますが
さて、提示された関数をご理解できましたでしょうか。
条件が変更されたときに、ご自身で式を変更するには
意外と、VBA以上の知識が必要な位複雑な式です。
別案ですが、フィルターオプション の機能を紹介しておきます。
http://www.eurus.dti.ne.jp/~yoneyama/Excel/filter3.htm
のサイトを参考にしてください。
機能を理解できれば、色々な応用が可能です。
毎日、実行するのであれば、一度、マクロの記録を実行すればよいです。
記録される内容は、ほんの1行ですので、VBAを理解するのも楽です。

Qエクセル 名簿でランダムに

お世話になります。

エクセル上の名簿(59人)でランダムに9グループ(7人を5グループ、6人を4グループ)に分けたいと思います。

マンネリを避けるためにランダムで組みたいと思いますが、エクセルの機能で良い具合にグループ分けをしてくれる機能は、ないでしょうか。

どなたかお詳しい方、よろしくお願いします。

Aベストアンサー

1.範囲 F2:F60 に59人の名前を入力
2.セル E2 に式 =RAND() を入力して、此れを下方にズズーッとドラッグ&ペースト
3.セル C2 に式 =VLOOKUP(SMALL(E$2:E$60,ROW(A1)),E$2:F$60,2,FALSE) を入力して、
  此れを下方に(セル C60 まで)ズズーッとドラッグ&ペースト
4.グループ分けは次のようにすればよろしいかと
   7人グループ1 → C2:C8
   7人グループ2 → C9:C15
   7人グループ… → ………
   7人グループ5 → C30:C36
   6人グループ1 → C37:C42
   6人グループ2 → C43:C48
   6人グループ3 → C49:C54
   6人グループ4 → C55:C60

Q順列組合せについて

12名で年6回ゴルフコンペを行っております。
4名1組で計3組でラウンドしておりますが
この6回の内に他の11名すべての人と
なるべく重複しないように組を組むには
どういった組み合わせ方をすれば
良いでしょうか?
宜しくお願い致します。

Aベストアンサー

 「みんなに一度は当たる」というだけの条件だったら、高々5回のラウンドでできちゃうんです。

 まず、条件を追加して、手作業で扱える程度の問題に帰着してしまいます。どんな条件かと言うと:
 12人のメンバーを1さんから12さん、と呼ぶことにします。(いや、●chとは関係ないです。)
で、二人ずつペアになって貰います。
ペア1は1さんと7さん、ペア2は2さんと8さん、ペアnはnさんとn+6さん(n=1~6)
こうして決めたペアはいつも一緒の組になる。これが追加した条件です。
 そうすると、
ラウンド1ではペア1~6はそれぞれA組,A組,B組,B組,C組,C組
ラウンド2ではペア1~6はそれぞれA組,B組,A組,C組,B組,C組
ラウンド3ではペア1~6はそれぞれA組,B組,C組,A組,C組,B組
ラウンド4ではペア1~6はそれぞれA組,B組,C組,B組,A組,C組
ラウンド5ではペア1~6はそれぞれA組,B組,B組,C組,C組,A組
という解がすぐ見つかりました。
 どのペアも他の5つのペアと一度は一緒にラウンドしてます。ですから、どの人も他の人全員と一度はラウンドしたことになる。だからこれで、「みんなに一度は当たる」という条件を満たしています。

 ただ、この組み合わせ方では、どの人もペアを組んだ相手とはいつも一緒である。これをもっと散らして平準化したいですね。

 そこで1~6さんは上記の組み合わせに従って戴くとして、7~12さんには以下のように組を代わって貰います。
ラウンド2と3ではA組と言われたらB組へ、B組と言われたらC組へ、C組と言われたらA組へ行く。
ラウンド4と5ではA組と言われたらC組へ、B組と言われたらA組へ、C組と言われたらB組へ行く。
 こうしますと、5回のラウンドのうちで、どの人も他の全員と当たり、しかも高々3回しか同じ人と当たりません。
 3回当たるのは
(1,8),(2,7),(3,10),(4,9),(5,12),(6,11)
 2回当たるのは
(1,9),(1,10),(2,9),(2,10),
(3,11),(3,12),(4,11),(4,12),
(5,7),(5,8),(6,7),(6,8)
で、他の「二人の組み合わせ」は1回ずつ当たります。

 ところで、6回のラウンドを有効に使えばもっと平準化できる(同じ人と1回しか当たらないということを減らすとともに、同じ人に3回当たるという組み合わせを少なくできる)に違いなく、コンピュータで力任せに探索すればナントカなるはず。そのうちやってみるかも知れません。

 「みんなに一度は当たる」というだけの条件だったら、高々5回のラウンドでできちゃうんです。

 まず、条件を追加して、手作業で扱える程度の問題に帰着してしまいます。どんな条件かと言うと:
 12人のメンバーを1さんから12さん、と呼ぶことにします。(いや、●chとは関係ないです。)
で、二人ずつペアになって貰います。
ペア1は1さんと7さん、ペア2は2さんと8さん、ペアnはnさんとn+6さん(n=1~6)
こうして決めたペアはいつも一緒の組になる。これが追加した条件です。
 そうすると、
ラウンド...続きを読む


人気Q&Aランキング