人気マンガがだれでも無料♪電子コミック読み放題!!

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 回答 (3件)

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
「重複しないグループ分けをエクセルで」の回答画像3

この回答への補足

補足です。

4回にこだわる必要はありません。
10回、20回でもいいので重複を避けられればと思います。

もう少し、プログラムの内容をよく読んでみます。

補足日時:2014/12/05 09:53
    • good
    • 1
この回答へのお礼

回答ありがとうございました。

こんなに長いプログラムになるんですね。
こんなに長くなるとは思わず、軽はずみに
質問をしてしまったことを深く反省します。


わがままついでにもう一つ教えていただけないでしょうか。

1~18を6つのグループに3つずつ重複なしで分けることは
可能でしょうか?

もし可能であればこのプログラムのどこを変更すればよいか
教えていただけると助かります。

大変申し訳ありませんがよろしくお願いします。

お礼日時:2014/12/04 18:53

> グループのメンバーは1名でもかぶらないようにしたいです。


> 1-2-3と1-2-9は重複と判断します。

1~9を3つに分ける場合はこの条件で出来ますが、12以上の時はどうあがいても無理です。
条件を変更するか、1~9だけにするかにしてください。
    • good
    • 0
この回答へのお礼

回答ありがとうございます。

12以上のときは無理なんですね。
考えるだけで嫌になってしまっていて可能かどうかは考えていませんでした。
適切なアドバイスありがとうございました。

お礼日時:2014/12/04 18:49

補足願います。



グループのメンバーは1名でもかぶっていたら駄目ですか?
つまり、1-2-3と1-2-9は重複ですか?重複ではないと判断しますか?

この回答への補足

回答ありがとうございます。

補足します。

グループのメンバーは1名でもかぶらないようにしたいです。
1-2-3と1-2-9は重複と判断します。

OFFSETやIF、ORなどを使いながら考えていますが
なかなかうまくできません。

何かいい方法があれば教えていただきたいと思います。

よろしくお願いします。

補足日時:2014/12/03 17:02
    • good
    • 1

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

前回回答していただいたVBAのプログラムを編集して
1~12までを3ずつ4グループになるべく重複をしないで
複数回、分けるにはどうしたらいい...続きを読む

Aベストアンサー

【つづき】

上記で出来上がった表を元に、組合せパターン数の表を作成するもの
#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度バラして・・・ってやってます
(元々数値の表側を見ればもっと少ない記述になりますが)

【つづき】

上記で出来上がった表を元に、組合せパターン数の表を作成するもの
#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("B...続きを読む

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回分

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...続きを読む

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

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行...続きを読む

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を理解するのも楽です。

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
       ...続きを読む

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
...続きを読む

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エクセル関数を使って、ランダム抽出をしたいです

エクセル関数を使って、ランダム抽出をしたいのですが
どの関数を使用すればいいのかわからないのです。

現在、1つのシートにいろいろなデータが入っているのですが、
D列のデータを使い、そのデータをランダムに25件抽出したいのです。

よろしくお願い致します。

Aベストアンサー

Sheet1にデータが入っているとして、そのD列のデータをSheet2のA列に取り出して操作をすることにします。
関数で取り出すのでしたらSheet2のA1セルに次の式を入力し下方にオートフィルドラッグします。
=Sheet1!D1
B1セルには次の式を入力し下方にオートフィルドラッグします。
=IF(A1="","",RAND())
C1セルには次の式を入力し下方にオートフィルドラッグします。
=IF(A1="","",RANK(B1,B:B))
D1セルには次の式を入力し下方にオートフィルドラッグします。
=IF(OR(COUNTIF(C:C,ROW(A1))=0,ROW(A1)>25),"",INDIRECT("A"&MATCH(ROW(A1),C:C,0)))
これでSheet2のD列にはランダムに抽出されたデータが並ぶことになります。
なお、F9のキーを押すことで抽出操作を繰り返すことができます。


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

人気Q&Aランキング