「みんな教えて! 選手権!!」開催のお知らせ

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

解決済

  • 質問者：huntingrush
  • 質問日時：
  • 回答数：12件

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

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

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

前回回答していただいたＶＢＡのプログラムを編集して
１～１２までを３ずつ４グループになるべく重複をしないで
複数回、分けるにはどうしたらいいでしょうか？
できれば複数回分けたところで全部の数が最低１回は同じ
グループに入るようにできると助かります。

今回も１－２－１２と１－２－１１は重複と考えます。

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

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

通報する

この質問への回答は締め切られました。

質問の本文を隠す

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

参考程度に

No.12ベストアンサー

  • 回答者： 30246kiku
  • 回答日時：

【つづき】



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

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 は、文字列で与えられたものを１度バラして･･･ってやってます
（元々数値の表側を見ればもっと少ない記述になりますが）
「重複しないグループ分けについて」の回答画像12
    • good
    • 1
    • 件
通報する
この回答へのお礼

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

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

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

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

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

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

通報する
お礼日時：2015/04/01 17:44

参考程度に

No.11

  • 回答者： 30246kiku
  • 回答日時：

【つづき】



ここは基本的に重複のないパターンを作成するものになります。
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

参考程度に

No.10

  • 回答者： 30246kiku
  • 回答日時：

【つづき】



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

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

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

参考程度に

No.9

  • 回答者： 30246kiku
  • 回答日時：

＃８です



＃８画像からチョッと変わりましたが･･･

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

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

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


Option Explicit

Const CGRPNUM As Long = 3 ' １グループの人数
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

どう思う？

No.8

  • 回答者： 30246kiku
  • 回答日時：

＃７です



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

処理全部、見直しました。
それにより、１グループ３人で １８人分けまで即座に応答があります。
（画像添付）
２１人～ は、２分では終わらない･･･
１グループ xx 人でも、ソコソコ動けるかもしれません。
前回までは、変更しやすいような雰囲気がありましたが、実際は･･･??
今回は、xx 人でもソコソコいけるかも

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


添付した画像では、１グループ３人の１８人なら･･･

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

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

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

通報する
お礼日時：2015/03/31 22:33

参考程度に

No.7

  • 回答者： 30246kiku
  • 回答日時：

【つづき】



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
    • 件
通報する

参考程度に

No.6

  • 回答者： 30246kiku
  • 回答日時：

＃５です



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

以下、参考程度で


Option Explicit

Const CGRPNUM As Long = 3 ' １グループの人数
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
    • 件
通報する

うーん・・・

No.5

  • 回答者： 30246kiku
  • 回答日時：

＃３です



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

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

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

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

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

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

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

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

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

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

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

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

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

通報する
お礼日時：2015/03/28 01:44

No.4

  • 回答者： WindFaller
  • 回答日時：

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



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

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

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

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

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

（私は、「１～１８を６つずつ[×4行の]３グループ」という場合、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
    • 件
通報する
この回答へのお礼

長い間考えていただいて誠にありがとうございました。
１２を３つずつ４グループを複数回繰り返してすべて重複を避けることができるのは３回までという結論に至ったので、できるだけ少ない重複（１回ないし２回）で４回、５回・・・とできるようなプログラムができればと考えていました。

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

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

通報する
お礼日時：2015/03/28 01:32

参考程度に

No.3

  • 回答者： 30246kiku
  • 回答日時：

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


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

９ ～ １５ は、ソコソコすぐに結果が出ます。
１８ ～ は、かなり時間がかかる様で、２分のリミットを。
２分経っても終わらなかったら、そこまで出来ていたものを表示して終わり

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


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 ' １グループの人数

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

　　v = InputBox("３の倍数を入力すると、３人ずつのグループに", , 9)
　　iNum = (Val(v) \ CGRPNUM) * CGRPNUM
　　If (iNum <= 0) Then Exit Sub
　　MsgBox iNum & " 人で処理します（時間リミットは２分）"
　　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 ' ２分のリミット
　　　　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
    • 件
通報する
この回答へのお礼

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

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

通報する
お礼日時：2015/03/25 15:32

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

Q質問する（無料）

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

関連するカテゴリからQ&Aを探す

ページトップページトップ

おすすめ情報

Q質問する（無料）

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

おすすめ情報