[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『4個の数字の和を全通り出したいです。』（TATTA）
・5個の箱A、B、C、Dがあります。
・箱の中には、30、50、70、90と書かれた玉が1個づつ入ってます。
・5個の箱から1個づつ玉を取り出した時の合計5個の数字の和は、
小さい方から並べると以下のようになります。
和の最小は、30が5個の時の150
2番目に小さい和は、30が4個と50が1個の時の170
：
：
：
和の最大は、90が5個の時の450
このように、X個の箱に入っている数字を1個づつ取り出して出来る
合計5個の数字の和を全通り表示させたいです。
■例えば以下のような手順です。
1.「箱の数」を（X個）としてA1に数値を入力する。
2.「箱の中に入っている数字の組み合わせ」をA2、A3、A4と全通り入力する。
※入力する数字の数は決まってません。15、35、55と3個の時もあれば、
20、40、60、80、100と5個の時もあります。
※どの箱の中の数字も、2.で入力した数字共通で入ります。
箱ごとに数字が異なることはありません。
※10、10、20、20のように同じ数字が重複して入力することはありません。
3.1.2.を入力したら、X個の箱から1個づつ数字を取り出したときの
5個の数字の和をC列に全通り表示させる。
以上です。
なにとぞよろしくお願いします。
このような和の組み合わせを全て出す処理をさせたいのですが
どのようにすれば良いのでしょうか？
＜ 使用 Excel：Office365、使用 OS：Windows10 ＞
上記の質問で
3.1.2.を入力したら、X個の箱から1個づつ数字を取り出したときの
5個の数字の和をC列に全通り表示させる。
で「5個の数字」と書いてますが、
※入力する数字の数は決まってません。15、35、55と3個の時もあれば、
20、40、60、80、100と5個の時もあります。
と書いてるとおり、必ずしも5個ではありません。
「A2〜Axまで入力されたX個の数字の和」が正確な表記です。
（TATTA） 2021/03/18(木) 22:38
課題１：組み合わせ数が多いと、予想通り時間がかかる
・5箱、4玉であれば問題ないですが ・7箱、5玉だと数秒待たされます。このあたりが限界？ ・10箱だと30分以上かかりました。 ・愚直に全ての組み合わせを求めているので、そもそも無茶？
課題２：ステップ数が多く面倒
・下記手順の９）10）で、箱数可変に対応する方法がわからない ・そのため全工程の自動化ができない ・仕方がないので、箱数ごとに、クエリを用意する？
試した手順：
１）下記のようなテーブルを作成 テーブル名：玉
数字
30
60
70
90
２）１）のテーブルを選んで「データの取得と変換」-「テーブルまたは範囲から」 ３）「閉じて次に読み込む」-「接続の作成のみ」 ４）「データの取得」-「その他のデータソースから」-「空のクエリ」 ５）数式バーに入力：= 玉 ６）「列の追加」-「カスタム列」 カスタム列の式：= 玉 ７）５）で追加した「カスタム列」を右クリックし、「重複する列」 ８）７）を列数＝箱数になるまで繰り返し ９）２列めの見出しの右端にある展開ボタンをクリック 10）同様に、３列め以降も展開ボタンをクリック 11）すべての列を選択し、「列の追加」-「統計」-「合計」 12）11）で追加された「加算」列を右クリックし、「他の列の削除」 13）「加算」列を右クリックし、「重複の削除」 14）「閉じて読み込む」
参考サイト： Power Query クロス結合(Cross Join) https://qiita.com/hrkasno/items/2b928d2e4713720cf6ce
（マナ） 2021/03/20(土) 12:43
例えば、箱の数が4個、玉が3個と決まっていれば、 単純にFor .. Nextのループで書くことができます。
Sub test0()
Dim k1 As Long, k2 As Long, k3 As Long, k4 As Long
Dim iBox As Long
Dim iBall As Long
Dim v As Variant
Dim total As Long
Dim p As Long
v = Range("A2:A4").Value '玉に表示された数値
iBall = 3
p = 1
For k1 = 1 To iBall
For k2 = 1 To iBall
For k3 = 1 To iBall
For k4 = 1 To iBall
total = v(k1, 1) + v(k2, 1) + v(k3, 1) + v(k4, 1)
Cells(p, "B") = total
p = p + 1
Next
Next
Next
Next
End Sub
しかし、箱の数や、玉の数が可変だと、上記のような書き方だと ループ回数が変化するので、どうしてもコードの手入れが必要になってしまいます。
それを回避するために、なんらかの工夫が必要です。 参照サイトでの(????)さんのコードをお借りして、作成してみました。
Sub test()
Dim LastRow&
Dim i&, iw&, iBox&, iBall&, j& ' & は型宣言子（As Longと同じです）
Dim total&
Dim cBall As Variant
Dim kosu&
iBox = Range("A1").Value '箱の数
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
cBall = Range("A2:A" & LastRow).Value '玉に表示された数値
iBall = UBound(cBall) '玉の数
kosu = iBall ^ iBox '組み合わせの数
ReDim iDim(iBox - 1) '作業配列
ReDim mat(1 To kosu, 1 To 1) As Long '結果配列
For i = 0 To kosu - 1
'iをiBall進数で表す
iw = i
For j = iBox - 1 To 0 Step -1
iDim(j) = iw Mod iBall
iw = (iw - iDim(j)) / iBall
Next
'合計の計算
total = 0
For j = iBox - 1 To 0 Step -1
total = total + cBall(iDim(j) + 1, 1)
Next
mat(i + 1, 1) = total
Next
[C1].Resize(kosu, 1) = mat
MsgBox "終了"
End Sub
参考にして下さい。
（γ） 2021/03/20(土) 16:44
ここ↓のコードをお借りして書いてみましたというよりも編集しただけです。私には到底書けませんm(__)m(^^; なので質問はお受けできません。Σ(￣ロ￣lll)ｶﾞｰﾝ https://excel-ubara.com/excelvba5/EXCELVBA264.html
Sheet2のA列の範囲から取得します。
Option Explicit
Sub てすと()
Dim MyA As Variant
Dim MyB As Variant
Dim MyC As Variant
Dim MyD As Variant
Dim MyTemp As Variant
Dim n As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim TempStrA As String
Dim TempStrB As String
Dim MyFlg As Boolean
MyA = Application.Transpose(Sheets("Sheet2").Range("A1").CurrentRegion.Resize(, 1).Value)
n = UBound(MyA)
ReDim MyTemp(LBound(MyA) To UBound(MyA))
For i = LBound(MyA) To UBound(MyA)
MyTemp(i) = i
Next
並び替え MyTemp, MyC
k = 1
ReDim MyD(1 To n, 1 To k)
For j = LBound(MyC, 2) To UBound(MyC, 2)
TempStrA = ""
TempStrB = ""
MyFlg = True
If j = 0 Then
TempStrA = "1"
TempStrB = "2"
Else
For i = 0 To n - 1
TempStrA = TempStrA & "_" & MyC(i, j - 1)
TempStrB = TempStrB & "_" & MyC(i, j)
If i > 0 Then
If MyC(i - 1, j) > MyC(i, j) Then
MyFlg = False
End If
End If
Next
End If
If TempStrA <> TempStrB And MyFlg = True Then
ReDim Preserve MyD(1 To n, 1 To k)
For i = 1 To n
MyD(i, k) = MyC(i, j)
Next
k = k + 1
End If
Next
With Sheets("Sheet1")
.Cells.ClearContents
k = 1
For j = LBound(MyD, 2) To UBound(MyD, 2)
MyB = ""
ReDim MyTemp(n - 1)
For i = 1 To n
MyTemp(i - 1) = MyA(MyD(i, j))
Next
並び替え MyTemp, MyB
.Cells(k, 1).Resize(UBound(MyB, 2) + 1, UBound(MyB, 1) + 1) = Application.Transpose(MyB)
k = k + UBound(MyB, 2) + 1
Next
End With
Erase MyA, MyB, MyC, MyD, MyTemp
End Sub
Public Sub 並び替え(ByRef MyX, ByRef MyY, Optional ByVal i As Long = 1)
Dim MyTemp As Variant
Dim MyAry As Variant
Dim j As Long
Dim ii As Long
If i < UBound(MyX) Then
For j = i To UBound(MyX)
MyAry = MyX
MyTemp = MyX(i)
MyX(i) = MyX(j)
MyX(j) = MyTemp
並び替え MyX, MyY, i + 1
MyX = MyAry
Next
Else
If IsEmpty(MyY) Or Not IsArray(MyY) Then
ii = 0
ReDim MyY(UBound(MyX), ii)
Else
ii = UBound(MyY, 2) + 1
ReDim Preserve MyY(UBound(MyX), ii)
End If
For j = LBound(MyX) To UBound(MyX)
MyY(j, ii) = MyX(j)
Next
End If
End Sub
（SoulMan） 2021/03/20(土) 17:07
Power Queryはなかなか慣れません。 引き続き、投稿を拝見して学習させていただきます。
以下、余談です。
各ステップの処理は、手続き的ではなく、宣言的なもののようですね。
ヘルプによると、
＞そして、リスト、レコード、テーブル メンバー式、
＞および let 式 (「式、値、および let 式」を参照) は、遅延評価 を使用して評価されます。
とあり、「遅延評価」いうことなので、
・上から順次計算されるわけではない。
・したがって、（そんな必要もないが）仮に記載の順序を逆にしても、
問題なく計算される。つまり、必要となったときに、その処理が行われるわけですね
・In の中の処理は、それが Let 内に書かれていれば、その時にはじめてそれが実行される
ということなんですねえ。
逆に言うと、For .. Nextなどをつかって、複数のステップを繰り返し処理するといった処理が 簡単にはできないのかなあ、と思っています。 こうした場合は、Haskell言語などと同様、 「繰り返しは、基本的に「再帰」を使う」と言うことになるんでしょうか。 なかなか難しいものですね。 （γ） 2021/03/20(土) 17:38
おはようございます。 昨夜お布団の中でよくよく考えていましたら わちきは大きな勘違いをしていたかもしれません。。。
Sheet1に↓とあった時に 5 30 50 70 90
Shtte2に↓の様に書き出します。 30 30 30 30 30 150 30 50 50 50 50 230 30 70 70 70 70 310 30 90 90 90 90 390 50 30 30 30 30 170 50 50 50 50 50 250 50 70 70 70 70 330 50 90 90 90 90 410 70 30 30 30 30 190 70 50 50 50 50 270 70 70 70 70 70 350 70 90 90 90 90 430 90 30 30 30 30 210 90 50 50 50 50 290 90 70 70 70 70 370 30 30 30 30 30 150 30 30 50 50 50 210 30 30 70 70 70 270 30 30 90 90 90 330 50 50 30 30 30 190 50 50 50 50 50 250 50 50 70 70 70 310 50 50 90 90 90 370 70 70 30 30 30 230 70 70 50 50 50 290 70 70 70 70 70 350 70 70 90 90 90 410 90 90 30 30 30 270 90 90 50 50 50 330 90 90 70 70 70 390 30 30 30 30 30 150 30 30 30 50 50 190 30 30 30 70 70 230 30 30 30 90 90 270 50 50 50 30 30 210 50 50 50 50 50 250 50 50 50 70 70 290 50 50 50 90 90 330 70 70 70 30 30 270 70 70 70 50 50 310 70 70 70 70 70 350 70 70 70 90 90 390 90 90 90 30 30 330 90 90 90 50 50 370 90 90 90 70 70 410 30 30 30 30 30 150 30 30 30 30 50 170 30 30 30 30 70 190 30 30 30 30 90 210 50 50 50 50 30 230 50 50 50 50 50 250 50 50 50 50 70 270 50 50 50 50 90 290 70 70 70 70 30 310 70 70 70 70 50 330 70 70 70 70 70 350 70 70 70 70 90 370 90 90 90 90 30 390 90 90 90 90 50 410 90 90 90 90 70 430 90 90 90 90 90 450
Option Explicit
Sub てすと()
Dim 箱 As Long
Dim MyA As Variant
Dim MyAry As Variant
Dim x As Variant
Dim MyColumn As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim n As Long
Dim ii As Long
With Sheets("Sheet1")
箱 = .Range("A1").Value
ReDim x(1 To 箱)
MyA = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value
End With
ReDim MyAry(LBound(MyA, 1) To UBound(MyA, 1) * UBound(MyA, 1), 1 To 箱)
For i = LBound(x) To UBound(x)
x(i) = MyA
Next
ii = 1
For n = LBound(x) + 1 To UBound(x)
For i = LBound(MyA, 1) To UBound(MyA, 1)
k = k + 1
If k > UBound(MyAry, 1) Then Exit For
For j = LBound(x) + 1 To UBound(x)
MyAry(k, j) = x(j)(i, 1)
Next
MyAry(k, 1) = x(n)(ii, 1)
If k Mod UBound(MyA, 1) = 0 Then ii = ii + 1
If ii > UBound(MyA, 1) Then Exit For
Next
Next
With Sheets("Sheet2")
.Cells.Clear
.Range("A1").Resize(UBound(MyAry, 1), UBound(MyAry, 2)).Value = MyAry
For j = 2 To 箱 - 1
増殖 MyAry, j
.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(MyAry, 1), UBound(MyAry, 2)).Value = MyAry
Next
MyAry = .Range("A1").CurrentRegion.Value
ReDim Preserve MyAry(LBound(MyAry, 1) To UBound(MyAry, 1), LBound(MyAry, 2) To UBound(MyAry, 2) + 1)
For i = LBound(MyAry, 1) To UBound(MyAry, 1)
MyAry(i, UBound(MyAry, 2)) = Application.Sum(Application.Index(MyAry, i, 0))
Next
.Range("A1").Resize(UBound(MyAry, 1), UBound(MyAry, 2)).Value = MyAry
ReDim MyColumn(UBound(MyAry, 2) - 1)
For i = LBound(MyAry, 2) To UBound(MyAry, 2)
MyColumn(i - 1) = i
Next
' .Range("A1").CurrentRegion.RemoveDuplicates Columns:=CVar(MyColumn)
End With
Erase MyA, MyAry, x, MyColumn
End Sub
Sub 増殖(ByRef x As Variant, ByVal 箱 As Long)
Dim y As Variant
Dim i As Long
Dim j As Long
For i = LBound(x, 1) + 1 To UBound(x, 1)
x(i, 箱) = x(i, 1)
Next
End Sub
Sub 多段配列()
Dim 箱 As Long
Dim MyA As Variant
Dim MyAry As Variant
Dim x As Variant
Dim MyColumn As Variant
Dim i As Long
Dim j As Long
Dim n As Long
Dim ii As Long
Dim xi As Long
With Sheets("Sheet1")
箱 = .Range("A1").Value
ReDim x(1 To 箱)
MyA = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value
End With
ReDim MyAry(LBound(MyA, 1) To UBound(MyA, 1) * UBound(MyA, 1) + UBound(MyA, 1), 1 To 箱)
For i = LBound(x) To UBound(x)
x(i) = MyA
Next
ReDim y(LBound(MyA, 1) To UBound(MyA, 1))
xi = 1
For n = LBound(x) To UBound(x)
For i = LBound(x) + 1 To UBound(x)
組み合わせ x(i), y, i - 1
If xi > UBound(y) Then Exit For
For ii = LBound(y) To UBound(y)
MyAry((n - 1) * UBound(MyA, 1) + ii, i) = y(ii)
MyAry((n - 1) * UBound(MyA, 1) + ii, 1) = y(xi)
Next
If i Mod UBound(x) = 0 Then xi = xi + 1
Next
Next
With Sheets("Sheet2")
.Cells.Clear
.Range("A1").Resize(UBound(MyAry, 1), UBound(MyAry, 2)).Value = MyAry
For j = 2 To 箱 - 1
増殖 MyAry, j
.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(MyAry, 1), UBound(MyAry, 2)).Value = MyAry
Next
MyAry = .Range("A1").CurrentRegion.Value
ReDim Preserve MyAry(LBound(MyAry, 1) To UBound(MyAry, 1), LBound(MyAry, 2) To UBound(MyAry, 2) + 1)
For i = LBound(MyAry, 1) To UBound(MyAry, 1)
MyAry(i, UBound(MyAry, 2)) = Application.Sum(Application.Index(MyAry, i, 0))
Next
.Range("A1").Resize(UBound(MyAry, 1), UBound(MyAry, 2)).Value = MyAry
ReDim MyColumn(UBound(MyAry, 2) - 1)
For i = LBound(MyAry, 2) To UBound(MyAry, 2)
MyColumn(i - 1) = i
Next
' .Range("A1").CurrentRegion.RemoveDuplicates Columns:=CVar(MyColumn)
End With
Erase MyA, MyAry, x, MyColumn, y
End Sub
Sub 組み合わせ(ByRef x As Variant, ByRef y As Variant, ByRef i As Long, Optional ByVal k As Long)
k = k + 1
i = i + 1
If i > UBound(x) Then i = 1
If k > UBound(x) Then Exit Sub
y(k) = x(i, 1)
組み合わせ x, y, i, k
End Sub
まだ不完全ですけど参考出展させてください。 てすと と 多段配列 でそれぞれ実行して 縦にならべて重複の削除で削除すればそれらしくなるような(^^; でも、、TimeUpです。途中でわけがわからなくなっちゃいました。(^^;
難しいですね。。。Power Query で解決されそうなので何かの参考になれば幸いです。 もう寝ます。。。おやすみなさいzzzzzzzzzzzzzzzz （SoulMan） 2021/03/21(日) 09:48
スピードのことはさておき、箱の数を可変にしてみました。 Power Query の経験が浅いので、思わぬ間違いがあるかと思います。 データの前提（と、テーブル名を玉とするなど）の前提は提示頂いたものと同じです。
【参考コード】
let
// ■ ここを変更してください。
箱の数=5,
ソース = Excel.CurrentWorkbook(){[Name="玉"]}[Content],
変更された型 = Table.TransformColumnTypes(ソース,{{"数字", Int64.Type}}),
//カスタム列を挿入
tbl1 = Table.AddColumn(変更された型,"カスタム",each ソース),
// 再帰関数1
fn列追加 = (parTable as table,n as number) as table=>
if n = 0 then
parTable
else
let
wtbl = Table.DuplicateColumn(
parTable,
"カスタム",
"カスタム" & Text.From(n-1)),
nextTable = @fn列追加(wtbl,n-1)
in
nextTable,
//列追加の実行
tbl2 = fn列追加(tbl1, 箱の数-2),
//再帰関数2
fn列内テーブルの展開 = (parTbl as table, parColumnNameList as list) as table =>
// parColumNameList が空なら, 再帰を終了
if List.IsEmpty(parColumnNameList) then
parTbl
else
let
// 実行すべき1列を取得
currentColumnName = List.First(parColumnNameList),
// parColumnNameListから第一列を削除する
nextColumNameList = List.RemoveFirstN(parColumnNameList, 1),
// 現在の列を展開する
wtbl = Table.ExpandTableColumn(
parTbl,
currentColumnName, //展開すべき対象列
{"数字"},
{ currentColumnName & ".数字"}),
// 再帰呼び出し
nextIterationTable = @fn列内テーブルの展開(wtbl, nextColumNameList)
in
nextIterationTable,
//2列目以降の列名のリスト
list1 = List.RemoveFirstN(Table.ColumnNames(tbl2), 1),
//列内テーブルの展開
tbl3 = fn列内テーブルの展開(tbl2,list1),
// 合計の挿入
tbl4 = Table.AddColumn(
tbl3,
"合計",
each List.Sum(List.Range(Record.ToList(_),0,Table.ColumnCount(tbl3)))),
// 合計列だけ選択
tbl5 = Table.SelectColumns(
tbl4,{"合計"}),
// 重複の排除
tbl6 = Table.Distinct(
tbl5)
in
tbl6
# なぜだか、箱が面になっていた。寝ぼけていたのかも。 # 15:15 コメントを修正 （γ） 2021/03/21(日) 12:08
「再帰」のサンプルありがとうございます。
一つの大きな壁を超えられそうな予感がします。
わたし個人のPower Queryへの期待は、
プログラミングの知識がなくても
簡単な操作だけで実現できることなので
この領域に踏み込むことに躊躇していました。
簡単にできないならマクロを使えばよいので。
でも、予想外に簡単そうだったので
ちょっと勉強してもよいかなと考え直しました。
'---- 少し変更させていただいて、動作確認しました。 期待通りの結果が得られました。
１）こんなテーブルを別途用意（テーブル名：箱）
箱数
10
２）接続専用クエリを追加（クエリ名：箱の数）
let
ソース = Excel.CurrentWorkbook(){[Name="箱"]}[Content],
変更された型 = Table.TransformColumnTypes(ソース,{{"箱数", Int64.Type}}),
箱数 = 変更された型{0}[箱数]
in
箱数
３）そのうえで、以下のように変更
let
ソース = Excel.CurrentWorkbook(){[Name="玉"]}[Content],
変更された型 = Table.TransformColumnTypes(ソース,{{"数字", Int64.Type}}),
フィルターされた行 = Table.SelectRows(変更された型, each [数字] <> null and [数字] <> ""),
tbl1 = Table.AddColumn(フィルターされた行,"カスタム",each フィルターされた行),
参考サイト： https://tsukaeru-excel.com/parameters
（マナ） 2021/03/21(日) 16:01
コメントありがとうございました。 箱数を設定するクエリーを別途作成してそれを利用するわけですね。 なるほど、なるほど。うまくいきました。
フィルタも勉強になります。ありがとうございます。
■以下、余談です。（お急ぎの方はスキップください。）
再帰を使うのかなあ、とぼんやり考えていただけです。 Power Queryは余り使ったことがないので、コード作成は苦労しました。 マイクロソフト作成のマニュアルだけが手元にありました。
マナさんのコードの理解から始めました。 ここが時間がかかりました。 全く慣れていないので、記事をもとに実行するのに苦労しました。
次に、当てずっぽうで再帰関数定義をやりましたが、 型がおかしいとか、そんなものは無い、とか色々叱られました。 最初の再帰関数はなんとか自力で書けました。フィボナッチ数列と同じ感じですか。
途中で、英語で検索すればよいかも、と思い、 power query recursive functionで検索したところ、 https://community.powerbi.com/t5/Community-Blog/Solving-Real-Life-Problems-with-Recursive-Functions-in/ba-p/731137 が参考になりました。二つ目の再帰関数の骨格はそれです。
次に苦労したのは全ての列の合計をとるところでした。 Table.ColumnNamesを使って、名前のリストは取れますが、次に進みません。 _ => の右辺が書けません。 これも検索で、 https://www.mrexcel.com/board/threads/power-query-how-to-sum-all-columns-except-a-b-c.1066814/ が参考になりました。
each List.Sum(Record.ToList(_))),で良いのに each List.Sum(List.Range(Record.ToList(_),0,Table.ColumnCount(tbl3)))), となっているのは、その名残です。 それにしても、Record.ToList(_)とは、気が付かなかった。
結局、ネットの検索結果の利用ということなのかな。とほほ。 それでも、勉強にはなりました。
引き続き、Power Query関係記事拝見させていただきます。
（γ） 2021/03/21(日) 17:25
こんばんは！ 一晩寝てお仕事してよくよく考えましたら二乗なんですね？？？ 3個でも10箱にすると答えが返って来ませんでした。(^^; でも、4個の5箱ぐらいなら一応返って来ました。 でもこれを右からとか箱の順番もとなると難易度はぐぐん〜〜っとあがるんでしょうね？
まぁ、、後は応用してください。
では、、では、、
Option Explicit
Sub てすと()
Dim 箱 As Long
Dim MyA As Variant
Dim MyAry As Variant
Dim i As Long
Dim k As Long
Dim n As Long
Dim MyTimer As Single
MyTimer = Timer
With Sheets("Sheet1")
箱 = .Range("A1").Value
MyA = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value
End With
If UBound(MyA, 1) ^ 箱 > Rows.Count Then
MsgBox "処理能力を超えています。。。"
Exit Sub
End If
ReDim MyAry(LBound(MyA, 1) To UBound(MyA, 1) ^ 箱, 1 To 箱)
k = 1
For i = LBound(MyAry, 1) To UBound(MyAry, 1)
MyAry(i, 1) = MyA(k, 1)
k = k + 1
If k > UBound(MyA, 1) Then k = 1
Next
k = 1
For n = 1 To 箱 - 1
For i = LBound(MyAry, 1) To UBound(MyAry, 1)
MyAry(i, n + 1) = MyA(k, 1)
If i Mod UBound(MyA, 1) ^ n = 0 Then k = k + 1
If k > UBound(MyA, 1) Then k = 1
Next
Next
With Sheets("Sheet2")
.Cells.Clear
With .Range("A1")
.Resize(UBound(MyAry, 1), UBound(MyAry, 2)).Value = MyAry
With .CurrentRegion
.Offset(, .Columns.Count).Resize(, 1).Formula = "=Sum(" & .Rows(1).Address(False, False) & ")"
End With
End With
End With
Erase MyA, MyAry
MsgBox Format(Timer - MyTimer, "###0.000秒")
ご指摘を受けてちょっと訂正です。。 このトピ主さん以外でも後々参考にされる方もいっらしゃるかもしれませんしね 4^10 4個10箱(1048576) で 9秒ほどでした。 あっ、悪い意味ではなくて私はスピード競技には全く興味がありませんので。。。あしからずご了承願います。(^^; なんでもかんでも配列というかぁ、、メモリー上でするのが早いわけではないのですね。。。 わかっちゃいるけどやめられない。。。ってやつですね。。。病気です(笑) では、、では、、、 ご指摘ありがとうございました。。。 （SoulMan） 2021/03/22(月) 22:04
SoulManさん、コメントさせていただきます。
玉の数が3個、箱が10個で結果が返ってこないとのこと。 3^10 = 59,049だから2,3秒で済むんじゃないかと思いまして確認したところ、 たしかに遅いですね。
MyAry(i, UBound(MyAry, 2)) = Application.Sum(Application.Index(MyAry, i, 0)) が遅くなっている原因のようです。
どうやら、配列に対するスライス処理（部分取り出し）は、製品仕様として 最適化が十分できていない印象です。 （タスクマネージャを見ると、メモリの取得と開放が頻繁に起きているようです。）
(1)配列に対して、原始的にループで合計をとったほうが早く確実かも知れません。
(2)どうしてもIndex処理を使うなら、
いったんワークシートに書き出してから、
mat(i, UBound(mat, 2)) = Application.Sum(Application.Index(rng.Rows.Item(i).Value, 0#))
のような書き方をすると、たぶん今の10倍以上は早くなります。（不思議ではあります）
数秒で答えが返って来ると思います。
■ちなみに、質問者さんから反応が無いのはとても残念です。
質問内容が、 (1)重複を除いた和の一覧だけでよいのか、 (2)重複を厭わず、すべての和の結果が欲しいのか、 (3)さらに、その時の、取り出した玉の数値も同時に必要なのか、 が不明確でした。
・私 の 2021/03/20(土) 16:44 の回答の後半部分のコードは、(2)のベースです。 ・マナさんのPowerQueryを使用したものは、(1)のベースです。 途中経過に(2)も(3)もあります。 ・SoulManさんのは、(3)のベースです。
私のコードも(3)のベースにできますが、反応が無いので躊躇しています。 また、(1)は、和の結果をdictionaryに突っ込めば良いだけです。
（γ） 2021/03/23(火) 08:27
おはようございます やっぱりその部分ですね 普段の私だったらシートに関数をセットしただろうと思います でも疲れていたんでしょうね 基本使い回しですから(^^;; そうですねトピ主さんどうされたんでしょうね まぁ、私は自分の暇つぶしに書いてますからいいんですけどね また、よろしくお願いします （SoulMan） 2021/03/23(火) 08:50
(1)重複を除いた和の一覧だけをシートに出力
という仕様にしました。
（その方が題材として面白い、工夫の余地か大きい、という個人的な理由です。）
「n個の数字を重複を許可してr回取り出す」という命題になると思います。
重複順列ですね。エクセルの関数ですとPERMUTATIONA。
?WorksheetFunction.Permutationa(4,5)
1024
?WorksheetFunction.Permutationa(4,10)
1048576
累乗でも計算できます。
?4^10
1024
?4^10
1048576
4数字、10箱だとちょうどシートの最大行数ですね。
列挙するには再帰を使うか、n進数を使う方法がおもいつきますが、簡単な後者でやってみます。
n進数は BASE関数で変換できますのでそれを利用します。
Dictionaryに合計を格納して重複を排除します。
Public Sub Test1()
Dim st As Single: st = Timer()
Dim dic As New Dictionary
Dim ary()
ary = Worksheets(1).Cells(1, 1).CurrentRegion.Value
Dim n As Long, r As Long
n = UBound(ary) - 1
r = ary(1, 1)
Dim i As Long
For i = 0 To n ^ r - 1
Dim s As String, j As Long, sum As Long
sum = 0
s = WorksheetFunction.Base(i, n, r)
For j = 1 To Len(s)
sum = sum + ary(Mid(s, j, 1) + 2, 1)
Next
dic(CStr(sum)) = sum
Next
Worksheets(1).Cells(1, 3).Resize(dic.Count) = WorksheetFunction.Transpose(dic.Items)
Debug.Print Format(Timer() - st, "0.0000000")
End Sub
4数字10箱で当方の環境では7秒台でした。
（hatena） 2021/03/24(水) 11:09
4数字10箱だとループ数が1048576となります。
和をだすだけなら順番は関係ないので無駄が多いですね。
30 30 30 30 50 も 30 30 30 50 30 も和は同じなので。
順番が関係ないなら順列ではなく組み合わせです。
重複組み合わせはエクセル関数なら、COMBINAです。
?WorksheetFunction.Combina(4,10)
286
4数字10箱でも286ループで済むので大幅に高速化できそうです。
しかし、重複組み合わせの列挙は難しそうです。
とりあえず検索してみました。ヒットしたのが下記のページ。
http://www.mathlion.jp/article/ar101.html
A,B,C,Dの4種類の記号から，重複を許して3個選ぶ組合せの総数を
出す場合の考え方として下記のような説明と
重複組合せの総数を知るためのアイデアは，r 個の◯と
n−1本のしきり｜を一列に並べる，というものです．
下記のような図がありました。
{A,A,B} ←→ ◯〇｜〇｜｜
{B,C,D} ←→｜〇｜〇｜〇
左と右は一対一に対応するということです。
これをみてふと気づきました。
右の順列は2進数ではないかと。
2進数の桁数は、n+r-1桁になるということなので、
4数字10箱なら、4+10-1=13桁の2進数、
2^13 = 8192ループで済むということになります。
COMBINAの286よりは大きいですが、重複順列の1048576に比べたら
桁違いに小さいです。
2進数利用のコードです。
BASE関数で2進数変換、Dictionalyで重複排除の部分は前回とほぼ同じです。
合計計算が複雑になるので別関数にしました。
Public Sub test2()
Dim st As Single: st = Timer()
Dim dic As New Dictionary
Dim ary()
ary = Worksheets(1).Cells(1, 1).CurrentRegion.Value
Dim n As Long, r As Long, s As String
n = UBound(ary) - 1
r = ary(1, 1)
Dim i As Long, res()
For i = 0 To 2 ^ (n + r - 1)
s = WorksheetFunction.Base(i, 2, n + r - 1)
If Len(Replace(s, "1", "")) = r Then
Dim d As Long
d = sum2(s, ary)
dic(CStr(d)) = d
End If
Next
Worksheets(1).Cells(1, 3).Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.Items)
Debug.Print Format(Timer() - st, "0.0000000")
End Sub
Public Function sum2(s As String, ary) As Long
Dim i As Long, j As Long
j = 2
For i = 1 To Len(s)
If Mid(s, i, 1) = 1 Then
j = j + 1
Else
sum2 = sum2 + ary(j, 1)
End If
Next
End Function
4数字10箱で0.04秒台、
想像以上の速度でした。(＠_＠;)
（hatena） 2021/03/24(水) 12:22
こんばんは！ なんだかいい感じになってきましたねぇ(^^; 私には全然わかりませんが、これこそ学校って感じですね。 勉強になります。(わかってませんが＿|￣|○)
目にも止まらぬ速さなのでケンシロウのこぶしの様なかんじでしょうか？ Power QueryといいExcelの進化についていけてないですね。精進しなければ。。。ですが、、もう無理です。Σ(￣ロ￣lll)ｶﾞｰﾝ 私は、雲の・・・でいきます(^^;
トピ主さんは、ひょっとして前半部分まではチャレンジされていて hatena さんの様な回答を期待されていたのかもしれませんね まぁ、、関心を持たれる方の多い題材でしょうから是非ぜひ勉強して習得いたいですね。＿〆＼(．．;) メモメモ ありがとうございました。 （SoulMan） 2021/03/24(水) 19:41
最初の質問後に、書き方が分かりづらいとのご指摘を受け、
週末に考えなおしていたのですが、体調を崩してしまい
皆様のご返答を確認させていただくことが出来ませんでした。
さまざまな方からご回答いただきましたのに大変申し訳ありません。
皆様の回答を拝見させていただきましたが、非常に専門的な内容と
なっていて、現在回答いただいていることを一つ一つ理解しようと
しています。
回答いただけた中で解決できる内容が確認できれば
改めて、お礼も含めて発言させていただきます。
皆様まことにありがとうございます。
（TATTA） 2021/03/24(水) 20:00
質問者さん 復帰おめでとうございます。
早速ですが、 質問内容が、 (1)重複を除いた和の一覧だけでよいのか、 (2)重複を厭わず、すべての和の結果が欲しいのか、 (3)さらに、その時の、取り出した玉の数値も同時に必要なのか、 が不明確でした。 は、どうだったのでしょうか？
hatenaさんの考察素晴らしいです。
重複を除いて和の一覧でよく、 しかも、玉に書いてある数字に重複はない（そう書いてある気がしますが）、 という前提であれば、強引に計算してしまう手もあると思います。
Option Explicit
Sub test()
Dim j&, k&
Dim hakosu&
Dim dic As Object
Dim t
t = Timer
worksheets(1).select
hakosu = Cells(1, 1)
ReDim dicary(1 To hakosu)
Set dic = CreateObject("Scripting.Dictionary")
For j = 2 To Cells(1, 1).End(xlDown).Row
dic(Cells(j, 1).Value) = Empty
Next
Set dicary(1) = dic
For k = 2 To hakosu
Set dicary(k) = fsub(dicary(k - 1), dicary(1))
Next
[C1].Resize(dicary(hakosu).Count, 1) = Application.Transpose(dicary(hakosu).keys)
Debug.Print Timer - t; Tab(20); "γ"
End Sub
Function fsub(obj1, obj2) As Object
Dim obj As Object, e1, e2
Set obj = CreateObject("Scripting.Dictionary")
For Each e1 In obj1
For Each e2 In obj2
obj(e1 + e2) = Empty
Next
Next
Set fsub = obj
End Function
玉の数を4個として 箱数=10ならhatenaさんのとほぼ同程度の速度だと思います。 箱数=15ならhatenaさんのよりも、速度は大分速いです。 (比較が同等でなかったらすみません）
（γ） 2021/03/24(水) 21:16
なるほど、、これは多段ディクショナリー＆インクリメントとでもいうのでしょうか？？？ 新手の方法ですね(^^;
これは早くも今年一番の○○トピになるかもしれませんよぉ(気が早い(^^;） 素晴らしいです。 （SoulMan） 2021/03/24(水) 21:46
γさん、素晴らしい。
そういう発想は私自身にはまったくなかったので刺激になります。
まだ、動作原理が理解できてませんが、ゆっくり精査させていただきます。
実は、重複組み合わせを再帰でやるのにチャレンジしてました。
いろいろ検索しても組み合わせの列挙のコード例は見つかりますが、
重複組み合わせのは見つからない。
そこで重複なし組み合わせのコードで一番シンプルなものを参考に
いろいろいじっていたら、できてしまいました。
参考にしたコード
https://teratail.com/questions/281147#reply-400587
上記のnCr関数が再帰関数なんですが、恐ろしくシンプルで、
これでいいのか不安になるぐらいです。
ix - 1 の部分の - 1 をとっただけで重複組み合わせになりました。
これをもとに、再帰の中で合計していって、
Dictionaryに格納するようにしました。
Option Explicit Dim ary() As Variant Dim dic As Dictionary
Private Sub Test3()
SWStart
Set dic = New Dictionary
ary = Worksheets(1).Cells(1, 1).CurrentRegion.Value
Dim n As Long, r As Long, s As String
n = UBound(ary) - 1
r = ary(1, 1)
Call CombinRSum(n, r, 0)
Worksheets(1).Cells(1, 4).Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.Keys)
Set dic = Nothing
SWStop
SWShow "hatena"
End Sub
Private Function CombinRSum(ByVal n As Long, ByVal r As Long, ByVal Num As Long)
If (r = 0) Then
dic(Num) = Empty
Else
Dim ix As Long
For ix = n To 1 Step -1
Call CombinRSum(ix, r - 1, ary(ix + 1, 1) + Num)
Next
End If
End Function
※下記の部分は、
SWStart
SWStop
SWShow "hatena"
https://hatenachips.blog.fc2.com/blog-entry-377.html
で紹介している高精度処理時間計測関数です。
マイクロ秒単位の精度がでます。
γさんのも含めてここまでくると Timer関数の分解能では不足している
と思いますので。
出力結果は Test1、 Test2とγさんのと同じになったので正しいと思います。
処理時間は γさんのより若干速いようです。（こちらの環境では）
（hatena） 2021/03/24(水) 23:12
ご質問について
望んでいた出力結果は（SoulMan）様が 3/21(日) 09:48に
[Sheet1]と[Sheet2]として記されている形が近いです。
箱A（30、50、70、90）
箱B（30、50、70、90）
箱C（30、50、70、90）
箱D（30、50、70、90）
箱E（30、50、70、90）
この状態で、
・箱A〜Eから1個ずつ取り出した数字5個の和を
構成する5個の数字とともに全通り出す。
30 30 30 30 30 150
30 50 50 50 50 230
30 70 70 70 70 310
30 90 90 90 90 390
50 30 30 30 30 170
※5個の数字の組み合わせはユニークのみ
30、30、50、50、50＝210
90、30、30、30、30＝210
↑
和は同じでも構成する数字が異なるので両方出す。
30、30、30、30、50＝170
50、30、30、30、30＝170
↑
和は同じで構成する数字も順番が異なるだけなので一方のみを出す。
という感じを希望していました。
また、
「強引に計算してしまう手もあると思います。」
こちらはまさにおっしゃる通りで、
最初はそれこそ原始的に、全ての数字の組み合わせを出して計算したのですが
この計算を、質問時に出した数字の組み合わせだけでなく、また、
組み合わせる数字の種類も5個だけでなく、3個や6個となった時にも
応用できる計算方法や処理方法が無いかと思って質問させていただきました。
ただ、思った以上に専門的な領域のようで、勉強不足な状態で質問をしてしまい
申し訳無いです。
（TATTA） 2021/03/24(水) 23:27
ならば前回の回答のコードの簡単な修正で可能です。
とりあえずSheet1に出力
C列にカンマ区切りで数値の組み合わせ
D列に合計値という仕様になってます。
大きい数値からの出力になります。
A B C
5 90,90,90,90,90 450
30 70,90,90,90,90 430
50 50,90,90,90,90 410
70 30,90,90,90,90 390
90 70,70,90,90,90 410
50,70,90,90,90 390
・・・・・・
１つの数値は1セルでということなら、出力後に「区切り位置」機能で分割してください。
Option Explicit Dim ary() As Variant '入力データ配列 Dim res() As Variant '結果配列 Dim rx As Long '出力位置
Private Sub Test4()
ary = Worksheets(1).Cells(1, 1).CurrentRegion.Value
Dim n As Long, r As Long, c As Long
n = UBound(ary) - 1 'データ数
r = ary(1, 1) '取り出し数
c = WorksheetFunction.Combina(n, r) '重複組み合わせ数
ReDim res(1 To c, 1 To 2)
rx = 0
Call CombinRSum(n, r, "", 0)
Worksheets(1).Cells(1, 2).Resize(c, 2).Value = res
End Sub
Private Function CombinRSum(ByVal n As Long, ByVal r As Long, ByVal txt As String, ByVal Num As Long)
If (r = 0) Then
rx = rx + 1
res(rx, 1) = Mid$(txt, 2)
res(rx, 2) = Num
Else
Dim ix As Long
For ix = n To 1 Step -1
Call CombinRSum(ix, r - 1, "," & ary(ix + 1, 1) & txt, ary(ix + 1, 1) + Num)
Next
End If
End Function
（hatena） 2021/03/25(木) 00:53
（γ） 2021/03/25(木) 08:21
素晴らしい回答をありがとうございました。
私一人では絶対にたどりつけなかったです。
本当に助かりました。
教えていただいたやり方を一つ一つ勉強して、
自分でも考えられる知識を身につけていきたいと思います。
本当にありがとうございました。
（TATTA） 2021/03/27(土) 22:05
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.