Excelで合計値を基にデータを均等に分ける

質問

どなたかご存知でしたら教えてください。
Excel で次のようなデータがあるとします。

.....A
1...10
2...15
3.....8
4...20
5...17

合計は 70 になります。これを 2 で割った 35 になるように、この 5 つのデータを振り分ける方法に悩んでいます。
この例の場合、2 と 4、1 と 3 と 5 で、それぞれ 35 になりますが、
結果として

.....A
1...10
2....8
3...17
--------　　　
4...15
5...20

などのように表示されるようにしたいのですが、
どのような方法であれば実現できるでしょうか？

宜しくお願いいたします。

回答No.9

_Kyle

#6=7=8　です。　何度もスミマセン。
仕様自体は#8(#7修正版)と変わらないのですが、
私自身の練習や実験を兼ねていろいろいじってたらかなり速くなったので。
「速くなった」のではなく「元が遅すぎた」というウワサもありますが…。

所要時間比でいうと、
　#6　：　750
　#7　：　×
　#8　：　700　　
　#9　：　350
ぐらいです。

「最適解を求める」という観点からは焼け石に水ですが、
（↑１０日かかるところが５日で済んだとしてもあまり嬉しくない）
単位時間あたりの探索量が多くなれば、
５分であれ１０分であれ一定時間内に「よりマシな解が見つかる」可能性が高くなります。

'--------------------------↓　ココカラ　↓--------------------------
　Dim ogAry()　 As Long
　Dim ixAry　　 As Variant
　Dim elCnt　　 As Long
　Dim gpCnt　　 As Long
　Dim tpAry()　 As Long
　Dim alSum　　 As Long
　Dim tpSum()　 As Long
　Dim btDif　　 As Long
　Dim btMax　　 As Long
　Dim WSF　　　 As WorksheetFunction
　Dim t　　　　 As Variant
'--------------------------
Sub Sample()
　Dim i　　 As Long
　t = Timer
　Set WSF = Application.WorksheetFunction
　Range("C:G").Clear
　elCnt = Range("A1").End(xlDown).Row
　gpCnt = Val(InputBox("いくつのグループに分けますか？"))
　With Range(Range("C1"), Cells(elCnt, "E"))
　　.Value = .Offset(0, -2).Value
　　.Sort Key1:=Range("C1"), Order1:=xlDescending, Header:=xlNo
　　ReDim ogAry(1 To elCnt)
　　For i = 1 To elCnt
　　　ogAry(i) = .Cells(i, 1).Value
　　Next i
　　ixAry = .Columns(2).Value
　End With
　Range("F1:F4").Value = WSF.Transpose(Array("最大", "最小", "差", "比"))
　alSum = WSF.Sum(ogAry)
　ReDim tpAry(1 To elCnt)
　ReDim tpSum(1 To gpCnt)
　For i = 1 To elCnt
　　tpAry(i) = WSF.Match(WSF.Min(tpSum), tpSum, 0)
　　tpSum(tpAry(i)) = tpSum(tpAry(i)) + ogAry(i)
　Next i
　btDif = WSF.Max(tpSum) - WSF.Min(tpSum)
　btMax = -Int(-(alSum + (gpCnt - 1) * btDif) / gpCnt)
　Call SubDsp
　If btDif < 2 Then Call SubMsg: End
　ReDim tpSum(1 To gpCnt)
　Call SubRef(1)
　Call SubMsg
End Sub
'--------------------------
Private Sub SubRef(ByVal elIdx As Long)
　Dim i　　 As Long
　Dim bfSum As Long
　Dim bfDif As Long
　For i = 1 To gpCnt
　　bfSum = tpSum(i)
　　tpSum(i) = tpSum(i) + ogAry(elIdx)
　　If tpSum(i) < btMax Then
　　　tpAry(elIdx) = i
　　　If elIdx = elCnt Then
　　　　bfDif = WSF.Max(tpSum) - WSF.Min(tpSum)
　　　　If bfDif < btDif Then
　　　　　btDif = bfDif
　　　　　btMax = -Int(-(alSum + (gpCnt - 1) * btDif) / gpCnt)
　　　　　Call SubDsp
　　　　　If btDif < 2 Then Call SubMsg: End
　　　　End If
　　　Else
　　　　Call SubRef(elIdx + 1)
　　　End If
　　End If
　　tpSum(i) = bfSum
　　If bfSum = 0 Then Exit For
　Next i
End Sub
'--------------------------
Private Sub SubDsp()
　Dim i　　　 As Long
　Dim j　　　 As Long
　Dim k　　　 As Long
　Range("C:E").Clear
　k = 1
　For i = 1 To gpCnt
　　For j = 1 To elCnt
　　　If tpAry(j) = i Then
　　　　Cells(k, 3).Value = ogAry(j)
　　　　Cells(k, 4).Value = ixAry(j, 1)
　　　　Cells(k, 5).Value = i
　　　　k = k + 1
　　　End If
　　Next j
　　Cells(k - 1, 3).Resize(, 3).Borders(xlEdgeBottom).Weight = xlMedium
　Next i
　Cells(1, 7).Value = WSF.Max(tpSum)
　Cells(2, 7).Value = WSF.Min(tpSum)
　Cells(3, 7).Value = btDif
　Cells(4, 7).Value = Format(WSF.Min(tpSum) / WSF.Max(tpSum), "#0.00%")
End Sub
'--------------------------
Private Sub SubMsg()
　MsgBox "これが最適解です" & vbCr & vbCr & _
　　"所要時間　：　" & Int(Timer - t) & "　sec."
End Sub
'--------------------------↑　ココマデ　↑--------------------------

お礼

再度バージョンアップ、ありがとうございます。
試行錯誤していただき、感激です！！(^o^)

回答No.8

_Kyle

#6=#7です。　スミマセン。#7のコードにミスがありました。

　btMax = Int((alSum + (gpCnt - 1) * btDif) / gpCnt + 0.5)

という部分が【　２ヶ所　】ありますが、いずれも正しくは

　btMax = -Int(-(alSum + (gpCnt - 1) * btDif) / gpCnt)

です。修正してください。

「ココは切り上げなきゃ」と考えつつ四捨五入を書く私って…。
要る枝まで切ればそりゃ速くなりますわね。

回答No.7

_Kyle

#6です。

「正常終了を待たずブレイクするのが標準の運用」という邪道なマクロですが、
とりあえず当座の役には立てたようで何よりです。

少し直してみました。

０．コードを（気持ちだけ）整理した。
　微妙に速くなりました。（#6に較べて1割くらい）

１．データ列／結果列の構成を変更・追加した。
　罫線で分けただけだと並べ替えや数式参照する際に不便なので。
　「色情報」の件の代替仕様も兼ねています。
　　　Ａ列：元データ-値
　　　Ｂ列：元データ-備考とか連番とか
　　　Ｃ列：結果-値
　　　Ｄ列：結果-備考とか連番とか
　　　Ｅ列：結果-グループ番号

なお、最適解は一つとは限らないので、
「すべての最適解を探せるように」というのも考えたのですが、
「最後まで調べて、結局解Ａが最適解であることが判った」
　↓
「解Ａ以降に見つけてスルーした解Ｂや解Ｃも最適解だった」
というケースで困る…というか覚えておくのが面倒なのと、
そもそも最適解を見つけること自体困難な場合の方が多いのでやめました。

'--------------------------↓　ココカラ　↓--------------------------
　Dim ogAry　　 As Variant
　Dim ixAry　　 As Variant
　Dim elCnt　　 As Long
　Dim gpCnt　　 As Long
　Dim tpAry()　 As Long
　Dim alSum　　 As Long
　Dim tpSum()　 As Long
　Dim btDif　　 As Long
　Dim btMax　　 As Long
　Dim WSF　　　 As WorksheetFunction
　Dim t　　　　 As Variant
'--------------------------
Sub Sample()
　Dim i　　 As Long

　t = Timer
　Set WSF = Application.WorksheetFunction
　Range("C:G").Clear
　elCnt = Range("A1").End(xlDown).Row
　gpCnt = Val(InputBox("いくつのグループに分けますか？"))

　With Range(Range("C1"), Cells(elCnt, "E"))
　　.Value = .Offset(0, -2).Value
　　.Sort Key1:=Range("C1"), Order1:=xlDescending, Header:=xlNo
　　ogAry = .Columns(1).Value
　　ixAry = .Columns(2).Value
　End With

　Range("F1:F4").Value = WSF.Transpose(Array("最大", "最小", "差", "比"))
　alSum = WSF.Sum(ogAry)

　ReDim tpAry(1 To elCnt)
　ReDim tpSum(1 To gpCnt)
　For i = 1 To elCnt
　　tpAry(i) = WSF.Match(WSF.Min(tpSum), tpSum, 0)
　　tpSum(tpAry(i)) = tpSum(tpAry(i)) + ogAry(i, 1)
　Next i
　btDif = WSF.Max(tpSum) - WSF.Min(tpSum)
　btMax = Int((alSum + (gpCnt - 1) * btDif) / gpCnt + 0.5)
　Call SubDsp
　If btDif <= 1 Then Call SubMsg: End

　ReDim tpSum(1 To gpCnt)
　Call SubRef(0)
　Call SubMsg
End Sub
'--------------------------
Private Sub SubRef(ByVal elIdx As Long)
　Dim i　　 As Long
　Dim f　　 As Boolean
　Dim bfSum As Long
　Dim bfDif As Long

　If elIdx = elCnt Then

　　bfDif = WSF.Max(tpSum) - WSF.Min(tpSum)
　　If bfDif < btDif Then
　　　btDif = bfDif
　　　btMax = Int((alSum + (gpCnt - 1) * btDif) / gpCnt + 0.5)
　　　Call SubDsp
　　　If btDif <= 1 Then Call SubMsg: End
　　End If

　Else

　　elIdx = elIdx + 1
　　For i = 1 To gpCnt
　　　If i = 1 Then
　　　　f = True
　　　Else
　　　　f = tpSum(i - 1) > 0
　　　End If
　　　If f Then
　　　　bfSum = tpSum(i)
　　　　tpSum(i) = tpSum(i) + ogAry(elIdx, 1)
　　　　If tpSum(i) < btMax Then
　　　　　tpAry(elIdx) = i
　　　　　Call SubRef(elIdx)
　　　　End If
　　　　tpSum(i) = bfSum
　　　End If

　　Next i
　End If
End Sub
'--------------------------
Private Sub SubDsp()
　Dim i　　　 As Long
　Dim j　　　 As Long
　Dim k　　　 As Long

　Range("C:E").Clear
　k = 1
　For i = 1 To gpCnt
　　For j = 1 To elCnt
　　　If tpAry(j) = i Then
　　　　Cells(k, 3).Value = ogAry(j, 1)
　　　　Cells(k, 4).Value = ixAry(j, 1)
　　　　Cells(k, 5).Value = i
　　　　k = k + 1
　　　End If
　　Next j
　　Cells(k - 1, 3).Resize(, 3).Borders(xlEdgeBottom).Weight = xlMedium
　Next i

　Cells(1, 7).Value = WSF.Max(tpSum)
　Cells(2, 7).Value = WSF.Min(tpSum)
　Cells(3, 7).Value = btDif
　Cells(4, 7).Value = Format(WSF.Min(tpSum) / WSF.Max(tpSum), "#0.00%")
End Sub
'--------------------------
Private Sub SubMsg()
　MsgBox "これが最適解です" & vbCr & vbCr & _
　　"所要時間　：　" & Int(Timer - t) & "　sec."
End Sub
'--------------------------↑　ココマデ　↑--------------------------

お礼

再び・・・お・おぉぉ・・・っです。
チラッと改良を思いついたはいいものの、ほぼ満足していたのですが、
こんなに早くバージョンアップしていただけるなんて、
ほんとに感謝です。早速コピらせて頂きました(^0^)
ありがとうございました！！

回答No.6

_Kyle

横から失礼します。

もし、近似解で良い（必ずしも最適解でなくともよい）のであれば、
マクロ（VBA）を使えばある程度近い解を見つけることはできます。

●動作の概要

A1セル以下にある任意の数の整数を、
【和が最大となる組と最小となる組との差がなるべく小さくなるように】
指定した数の組に振り分け、B1セル以下に表示する。

【途中であきらめること】を前提にしたマクロです。
適当なタイミングでEscキーを押して中断してください。

時間をかければいつかは最適解が見つかりますが、
総当りではないとはいえ可能性のある部分はすべて舐めるので、
条件次第ではマクロが終わるより先に世界が滅びてしまいます^^;;

また、早い段階で最適解が見つかった場合でも、
「最後まで調べ尽くしてそれが最適解であることを確かめる」のに時間がかかる場合があります。
一晩放置して調べたとしても、より良い解が見つかるとは限りません。

なお、上述の通り、ここでいう「最適解」は、
【和が最大となる組と最小となる組の差が最も小さくなる分け方】としています。
分散だの標準偏差だのといった種類のハナシではないようなので…。

参考画像は、1000以下のランダムな整数25個を6組に分けた事例です。
（最適解を見つけるのに15秒、それが最適解だということを確認するのに12分）

Excel2003で動作確認。
以上ご参考まで。長乱文長乱コード陳謝。

'--------------------------↓　ココカラ　↓--------------------------
　Dim ogAry　　 As Variant
　Dim elCnt　　 As Long
　Dim gpCnt　　 As Long
　Dim tpAry()　 As Long
　Dim alSum　　 As Long
　Dim tpSum()　 As Long
　Dim btDif　　 As Long
　Dim btMax　　 As Long
　Dim WSF　　　 As WorksheetFunction
　Dim t　　　　 As Variant
'--------------------------
Sub Sample()
　Dim i　　 As Long
　Set WSF = Application.WorksheetFunction

　With Range(Range("B1"), Cells(Range("A1").End(xlDown).Row, 2))
　　.Clear
　　.Value = .Offset(0, -1).Value
　　.Sort Key1:=Range("B1"), Order1:=xlDescending, Header:=xlNo
　　ogAry = .Value
　End With

　Range("C1:C4").Value = WSF.Transpose(Array("最大", "最小", "差", "比"))
　elCnt = UBound(ogAry)
　gpCnt = Val(InputBox("いくつのグループに分けますか？"))
　alSum = WSF.Sum(ogAry)

　t = Timer
　ReDim tpAry(1 To elCnt)
　ReDim tpSum(1 To gpCnt)
　For i = 1 To elCnt
　　tpAry(i) = WSF.Match(WSF.Min(tpSum), tpSum, 0)
　　tpSum(tpAry(i)) = tpSum(tpAry(i)) + ogAry(i, 1)
　Next i
　btDif = WSF.Max(tpSum) - WSF.Min(tpSum)
　btMax = alSum + (gpCnt - 1) * btDif
　Call SubDsp

　t = Timer
　ReDim tpAry(1 To elCnt)
　ReDim tpSum(1 To gpCnt)
　tpSum(1) = ogAry(1, 1)
　tpAry(1) = 1
　Call SubRef(1)

　MsgBox "これが最適解です" & vbCr & vbCr & _
　　"所要時間　：　" & Int(Timer - t) & "　sec."

End Sub
'--------------------------
Private Sub SubRef(ByVal elIdx As Long)

　Dim i　　 As Long
　Dim f　　 As Boolean
　Dim bfSum As Long

　If btDif <= 1 Then Exit Sub

　If elIdx = elCnt Then
　　If WSF.Max(tpSum) - WSF.Min(tpSum) < btDif Then
　　　btDif = WSF.Max(tpSum) - WSF.Min(tpSum)
　　　btMax = alSum + (gpCnt - 1) * btDif
　　　Call SubDsp
　　End If
　Else
　　elIdx = elIdx + 1
　　For i = 1 To gpCnt
　　　If i = 1 Then
　　　　f = True
　　　Else
　　　　f = tpSum(i - 1) > 0
　　　End If
　　　If f Then
　　　　bfSum = tpSum(i)
　　　　tpSum(i) = tpSum(i) + ogAry(elIdx, 1)
　　　　If tpSum(i) * gpCnt < btMax Then
　　　　　tpAry(elIdx) = i
　　　　　Call SubRef(elIdx)
　　　　End If
　　　　tpSum(i) = bfSum
　　　End If
　　Next i
　End If

End Sub
'--------------------------
Private Sub SubDsp()
　Dim i As Long
　Dim j As Long
　Dim k As Long

　Columns(2).Clear

　k = 1
　For i = 1 To gpCnt
　　For j = 1 To elCnt
　　　If tpAry(j) = i Then
　　　　Cells(k, 2).Value = ogAry(j, 1)
　　　　k = k + 1
　　　End If
　　Next j
　　Cells(k - 1, 2).Borders(xlEdgeBottom).Weight = xlMedium
　Next i

　Cells(1, 4).Value = WSF.Max(tpSum)
　Cells(2, 4).Value = WSF.Min(tpSum)
　Cells(3, 4).Value = btDif
　Cells(4, 4).Value = Format(WSF.Min(tpSum) / WSF.Max(tpSum), "#0.00%")

End Sub
'--------------------------↑　ココマデ　↑--------------------------

お礼

お・・・おぉぉ・・・！すごいです。
早速試してみましたが、期待通りの結果を得ることができました。
本当に感謝です。助かりました！
ふと、最初にAでいくつかのセルに色を付けておいて
その色情報ともにBにもっていければ
結果を見たとき、Aのどれとどれがグループになったのかが
よりわかりやすいかも、と思いました。
頑張ってみます。ありがとうございました！

回答No.5

web2525

数が20で5等分は非常に難しいですよ

数が5個で2等分だから計算式で求められる
2等分する場合の割合が
1：4か2：3の2通りしか存在しないため
最大値+ｘを求める事だけで解が得られるからです。

数値が20あり5等分の組み合わせを総当たりで計算する事は非常に難解極まる計算式が必要となるでしょう。

お礼

・・・で、ですよね・・・はぁ(>_<)
やはり今までやっていたように
.....A
1...10
2...15
3.....8
4...20
5...17
の合計とその2等分(35)を出し、上から10+15=25, 25+8=33、で区切り、
また20+17=37というようにするしかないようですね。
この問題点は、昇順に並べて上から順に足していったのでは
大幅に35と異なる場合がよくあるからで、
数字の大きいのと小さいのをうまく組み合わせることができないか、
と思ったのです(いまは手動です・・・)
また何か名案が浮かんだら、是非教えてください。
私ももう少し考えてみます。ありがとうございました。

回答No.4

web2525

考え方はNo2と一緒です

5の整数の最大値に他の数を足した結果の中から合計の1/2に一番近い組み合わせを求める

例：5つの数が20,18,14,13,5の場合
20
18+20= 38
14+20= 34
13+20= 33
5+20= 25
合計の23に一番近い組み合わせは14+20となるので
｛20,14｝と｛18,13,5｝の組み合わせに分ける
最大値が合計の1/2を超える場合は無条件で｛最大値｝と｛その他｝の組み合わせとなる。

ただし数字が6以上ある場合や3等分する場合などはもっと複雑になってしまいます。

Excelの計算式だけで結果を導き出すのであれば
A1:A5に数値が有り降順に並んでいると仮定し
=LARGE(A2:A5,MATCH(MIN(IF(INDEX(A2:A5+A1,0)>SUM(A1:A5)/2,INDEX(A2:A5+A1,0)-SUM(A1:A5)/2,SUM(A1:A5)/2-INDEX(A2:A5+A1,0))),IF(INDEX(A2:A5+A1,0)>SUM(A1:A5)/2,INDEX(A2:A5+A1,0)-SUM(A1:A5)/2,SUM(A1:A5)/2-INDEX(A2:A5+A1,0)),0))
配列計算になるので[Sift]+[Ctrl]+[Enter]で確定

この計算式で求められる数値と最大値の組み合わせとその他の組み合わせの2グループに分けることが出来ます。

計算式自体はもっとシンプルにする方法はあるかも知れません。

お礼

詳しくお答えいただき、本当にありがとうございました。
大体の考え方は理解できたように思います。
実際には数字が 20 以上あることが多く、
等分も少なくても 5 等分するので、
あまりのややこしさに諦めそうになりますが、
この計算式を基に考えてみたいと思います。

回答No.3

web2525

＞必ずしも割り切れないのですが、その場合はできないのでしょうか。

答えのない問題自体は解くことができません。

例題1.
5つの整数の合計が71の場合、合計が1/2になるように2つのグループに分けろ

整数の組み合わせで合計35.5にする事は出来ません

例題2.
5つの整数の合計が70の場合、合計が1/2になるように2つのグループに分けろ、5つの整数｛36、20、10、3、1｝

最大値が既に1/2の35を超えているので答えは出ません。

共に解が無い問題になっていますので、どんなに計算しても回答は出てきません。
出題の形式を変更するしかないでしょう。

例題3.
5つの整数の合計が70の場合、それぞれの合計が1/2に一番近くなる2つのグループに分けた場合の組み合わせを求めろ

とか

補足

なるほど。ありがとうございます。
最後の例題 3 のように、合計が 1/2 に一番近くなる 2 つのグループに分けた組み合わせを求める、というのは、具体的にはどのようにするのでしょうか？
何度も申し訳ありませんが、宜しくお願いいたします。

回答No.2

web2525

考え方としては
最大値を基準に大きい方から足し算を行い1/2以上の場合は、次の数・・・・
と繰り返し1/2になった時点で終了
足した数が1/2以下の場合は最小値を足して1/2を超える場合は次の数を足す。

総当たり的な計算をする事になると思います。

必ず解が有ると言う事が条件
数値　A B C D Eが降順に並んでいるとし
A+B＞合計/2なら
A+C＜合計/2→A+C+E＞合計/2なら
A+D+E＝合計/2
のような感じ

補足

ありがとうございます。
必ず解がある、というのは割り切れる、という意味でしょうか。
必ずしも割り切れないのですが、その場合はできないのでしょうか。

回答No.1

fujillin

データが5つとして、

1）3,3,3,3,3の場合
2）1,1,1,1,50の場合

などの単純に1/2にできない場合（上はほんの一例）の処置をどうするのか決めておかないと、必ず出来る保証が無い問題は解決できないのでは？
あるいは、解が複数存在する場合とか…