[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『組合せ作成』（亜美ちゃん）
ABC ABC ABC の組合せ簡単に作成したいのですがいい方法ありませんでしょうか。 ＩＮＩＤＲＥＣＴ関数と&を使ってできそうな気がするのですが・・・ ちなみにAAA AAB AAC ABA ACA・・・CCC まで作成したいのですがいちいち入力が 大変ですし、間違いがあるかもしれないのでよろしくお願いいたします。 例では3つのグループで3*4*3種類なのですが 実際は4つのグループで40*70*40種類作成しなければならないのです。 XP-SP2,2003使用です。
不得意な分野なので、取りあえずご質問の内容だけ確認させてください。
＞例では3つのグループで3*4*3種類なのですが
何が３つのグループなのですか？ 3*4*3のそれぞれの意味は？
私には、一つのグループで、3*3*3 （全27種類）に思えるのですが。
<追記> カキコしたあとで、気がついたのですが、
第1ABC、第2ABC、第3ABC で3つのクループと云うことですか？
しかし、3*4*3だとすると 第1はABC、第2はABCD、第3はABC ではないですか？ ↑ つまり、ここは"D"では？
それが正しいとすると、実際は 40*70*40ですから、全112,000種類と云うことになりますか？
（半平太）
すみません 第1はABC、第2はABCD、第3はABC ではないですか ご指摘のとおりです。 実際は 40*70*40ですから、全112,000種類ということです。
＞ 実際は 40*70*40ですから、全112,000種類ということです。
あまりの量に逃げ出し寸前です。取りあえずの案（バージョンは、XL2007を想定しています）。
１．A、B、C 各列一行目に「1」と入力
２．式の入力 (1) A2セル =IF(AND(B1=70,C1=40),A1+1,A1) (2) B2セル =IF(C1=40,IF(B1=70,1,B1+1),B1) (3) C2セル =MOD(ROW(A2)-1,40)+1
2行目の式を112,000行目までコピー
行 _A_ _B_ _C_ 1 1 1 1 2 1 1 2 3 1 1 3 4 1 1 4
（半平太）
こんな塩梅でどうでせう。(ROUGE)
'----
Sub test()
Dim txt1 As String, txt2 As String, txt3 As String
Dim x, y, z, tbl()
Dim i As Long, ii As Long, iii As Long, n As Long, m As Long
txt1 = Application.InputBox("組み合わせに使用する文字を" & Chr(10) _
& "「，」区切りで入力してください。", "その１", Type:=2)
txt2 = Application.InputBox("組み合わせに使用する文字を" & Chr(10) _
& "「，」区切りで入力してください。", "その２", Type:=2)
txt3 = Application.InputBox("組み合わせに使用する文字を" & Chr(10) _
& "「，」区切りで入力してください。", "その３", Type:=2)
x = Split(Replace(txt1, "，", ","), ",")
y = Split(Replace(txt2, "，", ","), ",")
z = Split(Replace(txt3, "，", ","), ",")
m = 1
ReDim tbl(1 To WorksheetFunction.Min(Rows.Count, (UBound(x) + 1) * (UBound(y) + 1) * (UBound(z) + 1)), 1 To 1)
For i = 0 To UBound(x)
For ii = 0 To UBound(y)
For iii = 0 To UBound(z)
n = n + 1
If n > Rows.Count Then
n = 1
m = m + 1
ReDim Preserve tbl(1 To UBound(tbl, 1), 1 To UBound(tbl, 2) + 1)
End If
tbl(n, m) = x(i) & y(ii) & z(iii)
Next iii
Next ii
Next i
Cells.ClearContents
Range("A1").Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl
Erase tbl, x, y, z
End Sub
新規ブックの標準モジュールに
'============================================================
Sub main()
Dim idx As Long
Dim g0 As Long
Dim wk As Variant
Dim ans() As Variant
' ↑組み合わせメンバーを取得する配列
Dim rng As Range
' ↑組み合わせセル範囲
Call サンプル作成
Set rng = Range("a1").CurrentRegion
Call ttlhit_init(rng.Columns.Count)
For g0 = 1 To rng.Columns.Count
With rng.Cells(1, g0)
Call ttlhit_add(Range(Cells(1, .Column), Cells(Rows.Count, .Column).End(xlUp)))
End With
Next
idx = 10
ReDim ans(1 To rng.Columns.Count)
Do While ttlhit_get(ans()) = 0
wk = ""
For g0 = LBound(ans()) To UBound(ans())
wk = wk & ans(g0)
Next
Cells(idx, 1).Value = wk
idx = idx + 1
Loop
MsgBox "以上" & idx - 10 & "通り"
Call ttlhit_term
End Sub
'============================================================
Sub サンプル作成()
Cells.ClearContents
Range("a1:d1").Value = [{"a","a","a","a"}]
Range("a2:d2").Value = [{"b","b","b","b"}]
Range("a3:d3").Value = [{"c","c","c","c"}]
Range("d4").Value = "d"
MsgBox "サンプル作成 セルＡ１０から処理を開始します"
End Sub
別の標準モジュールに組合せ処理ルーチン
Private ttl_rng() As Range
Private ttl_idx() As Long
Private ttl_a_num As Long
'===================================================================
Sub ttlhit_init(hitnum As Long)
'組合せ処理の開始宣言
'input : hitnum 抜き取り数
Dim g0 As Long
Erase ttl_rng()
Erase ttl_idx()
ReDim ttl_rng(1 To hitnum)
ReDim ttl_idx(1 To hitnum)
For g0 = LBound(ttl_idx()) To UBound(ttl_idx())
ttl_idx(g0) = 1
Next
ttl_idx(UBound(ttl_idx())) = 0
ttl_a_num = 0
End Sub
'======================================================================
Sub ttlhit_add(rng As Range)
'組合せ標本セル範囲の登録
'input : rng 連続したセル範囲
Set ttl_rng(ttl_a_num + 1) = rng
ttl_a_num = ttl_a_num + 1
End Sub
'======================================================================
Function ttlhit_get(ans()) As Long
'組み合わせメンバーを配列に出力する
'output: ans() メンバの配列
' ttlhit_get:0 -- 正常に配列取得
' 1 -- メンバの終わり
Dim g0 As Long
ttlhit_get = 1
For g0 = UBound(ttl_idx()) To LBound(ttl_idx()) Step -1
If ttl_idx(g0) + 1 <= ttl_rng(g0).Count Then
ttl_idx(g0) = ttl_idx(g0) + 1
ttlhit_get = 0
Exit For
Else
ttl_idx(g0) = 1
End If
Next
If ttlhit_get = 0 Then
For g0 = LBound(ttl_idx()) To UBound(ttl_idx())
ans(g0) = ttl_rng(g0).Cells(ttl_idx(g0)).Value
Next
End If
End Function
'======================================================================
Sub ttlhit_term()
'組合せ処理に終了
Erase ttl_rng()
Erase ttl_idx()
ttl_a_num = 0
End Sub
予め組合せ処理部分を再利用可能にしておくと 同じような事象に対応できると思いますよ！！ （私は、よくクラス化（オブジェクト）して利用しています） 尚、列が増えてもコードの変更は殆ど要らないと思います。
ichinose
これは一体何のデータでっしゃろ？
スポーツでは無いみたいやし、薬品混合の臨床データ？ それとも金属強度テストの
データ？
ま、それはともかく、Sheet2でグループ分けしたデータをSheet1に標本別に取り出す
マクロをROUGEせんぱいの工法をパクリながら作成してみました。
Sheet2のデータをこんな塩梅に並べて実行しませう。
A B C D E
1 Aグループ Bグループ Cグループ Dグループ Eグループ
2 標本A1 100g C1 D1 E1
3 標本A2 120g C2 D2 E2
4 標本A3 130g C3 D3 E3
5 ... ... ... ... ...
6 ... ... ... ... ...
7 ... ... ... ... ...
8 ... ... ... ... ...
. ... ... ... ... ...
.
.
（弥太郎）
'--------------------------
Sub Get組合せ()
Dim i As Long, n As Long, m As Integer, Cnt As Long, u As Integer, x(), tbl, y()
Dim ii As Long, iii As Long, iiii As Long, iiiii As Long, b As Integer
With Sheets("sheet2")
b = StrConv(InputBox("グループ数はなんぼでっか？"), vbNarrow)
tbl = .Cells(2, 1).Resize(.Range("a:" & Chr(64 + b)). _
Cells.Find("*", , , , xlByRows, xlPrevious).Row - 1, b)
End With
For u = 1 To b
For i = 1 To UBound(tbl, 1)
If Not IsEmpty(tbl(i, u)) Then
ReDim Preserve y(i - 1)
y(i - 1) = tbl(i, u)
End If
Next i
ReDim Preserve x(u - 1)
x(u - 1) = y
If u > 2 Then Cnt = IIf(Cnt = 0, (UBound(x(u - 2)) + 1) * (UBound(x(u - 1)) + 1), _
Cnt * (UBound(x(u - 1)) + 1))
Next u
Application.ScreenUpdating = False
ReDim tbl(1 To IIf(Cnt > 60000, 60000, Cnt), 1 To UBound(x) + 1)
With Sheets("sheet1")
.Cells.ClearContents
For i = 0 To UBound(x(0))
For ii = 0 To UBound(x(1))
For iii = 0 To UBound(x(2))
Select Case u - 1
Case 3
Call work(u, n, tbl, m, Cnt)
For b = 1 To 3
tbl(n, b + m) = x(b - 1)(IIf(b = 1, i, IIf(b = 2, ii, iii)))
Next b
Case 4
For iiii = 0 To UBound(x(3))
Call work(u, n, tbl, m, Cnt)
For b = 1 To 4
tbl(n, b + m) = x(b - 1)(IIf(b = 1, i, IIf(b = 2, ii, _
IIf(b = 3, iii, iiii))))
Next b
Next iiii
Case 5
For iiii = 0 To UBound(x(3))
For iiiii = 0 To UBound(x(4))
Call work(u, n, tbl, m, Cnt)
For b = 1 To 5
tbl(n, b + m) = x(b - 1)(IIf(b = 1, i, IIf(b = 2, ii, _
IIf(b = 3, iii, IIf(b = 4, iiii, iiiii)))))
Next b
Next iiiii
Next iiii
End Select
Next iii
Next ii
Next i
.Cells(1, 1).Offset(, m).Resize(, u - 1) = Sheets("sheet2").Cells(1, 1).Resize(, u - 1).Value
.Cells(2, 1).Resize(UBound(tbl, 1), UBound(tbl, 2)) = tbl
End With
Application.ScreenUpdating = True
End Sub
Sub work(u, n, tbl, m, Cnt)
n = n + 1
If n > UBound(tbl, 1) Then
With Sheets("sheet1")
.Cells(1, 1).Offset(, m).Resize(, u - 1) = Sheets("sheet2").Cells(1, 1).Resize(, u - 1).Value
n = 1
m = m + u
ReDim Preserve tbl(1 To UBound(tbl, 1), 1 To UBound(tbl, 2) + u)
End With
End If
End Sub
ちょとしゅうせぇ＾＾ （弥太郎）5/7 10:04
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.