エクセルVBAで表の数値の微調整

質問

いつもお世話様です。
かなりの難問に突き当たってしまいました。お助けいただけると幸いです。

【前提】
A1:H11に表があります。（実際のセル番地は違います）
A1:G10には数値が入力されています。（空白セルもありますが、数値が入っている場合はすべて下二桁めは四捨五入され、1230や5420、230といった感じです。1234や5423、234などはありません。）
H1:H10には各行のTOTALがSAM関数で=SUM(A1:G1)のように入っています。
A11:H11には各列のTOTALがSAM関数で=SUM(A1:A10)のように入っています。

つまりH11に総合計があることになります。

【質問】
H11のセルの総合計の数値を、任意の値に変えた場合、それ以外の数値を、その割合で増減させ、やはり下二桁めは四捨五入したいのです。

その割合で単純にA1:G10の数値をFor Nextで変更させることは出来るのですが、そうすると場合により（というか、ほとんどの場合ですが）合計が変わってしまいます。

仮に、H11が55320という値、変更後が55000だったとすると、各セルの数値に55320/55000を乗じてROUNDすると、各列の合計はところどころプラスマイナス10程度ことなり、総合計は55030とか54980とか微妙に変わってしまうのです。
四捨五入だからどうしようもないのですが、これをうまく調整したいのです。

優先順位は

1.総合計（指定した任意の値は変えられない。）
2.各列の縦計
3.各セルに対する変更の比重を極力一定に

です。

そうするために、まず各列の1～10セルのなかの最大値で端数を調整するしかないと思うのですが、（他にいい方法があれはそれでもいいですが）こうなってくるとわたしのVBAの知識では遠く及ばなくなってしまいます。

どうかご教示お願いいたします。

回答No.5

Wendy02 · ベストアンサー

こんばんは。
merlionXX さん、コードを見せていただきました。

私のマクロで、固定値の書き込み位置が違っていましたね。
ちゃんと読めばよかったのですが、すみませんでした。

最後の最大値の修正部分は、こうすれば、速いのではありませんか？
同じことかもしれませんが、ダイレクトで、その場所に行きます。

＞For Each c In Range("DATA") 'Range("DATA")の中で最大の値+df

With Range("DATA").Find(mx, LookIn:=xlValues)
　　 .Value = .Value + df
End With

お礼

Wendy02さん、ほんとうにいつも助けられます。

With Range("DATA").Find(mx, LookIn:=xlValues)
　　 .Value = .Value + df
End With

こんな呪文があるんですねえ！！すごい。

試してみましたがとっても高速化されました。
これって最大値が複数でも、最初の1箇所にだけ作用するんですよね？（やってみたらそのようでしたが、念のためお聞きしておきます。）

回答No.6

Wendy02

merlionXX さん、こんにちは。

Wendy02です。

＞これって最大値が複数でも、最初の1箇所にだけ作用するんですよね？

Find メソッドでは、セル1つしか選択できないのです。それも、順序がありますね。デフォルトでは、上から下、左から右の、近い方になるのですが、検索方向(SearchOrder)が、行(xlByRows)だったら、行に対して、列(xlByColumns)でしたら、列に対してなのですが、おそらく、若干、行のほうが検索スピードが速いような気がします。

たぶん、SpecialCells なんかも、本来は、そういう仕組みなのだと思いますが、複数を選択した結果としてしか、私たちの目には映りませんね。

お礼

ありがとうございました。
助かりました。

回答No.4

imogasi

私が仕事で、「合計の四捨五入値」と「各項の四捨五入値の合計」が合わない場合にぶつかっていたときのやり方を、ＶＢＡでやってみました。
ただし、お許しいただきたいのは、
（１）データが１の位の四捨五入になっていることを、回答を複雑にせずに、簡単にするため、数値直接で考えた。言い換えると１／１０の値で考えた。普通はこのケースが多い。
（２）（横）行の合計調整だけで終わっている。縦列も同じ理屈でできるが、回答がながくなり、うんざりでしょうから省略。
コードを短くするため、エクセル関数をできるだけ利用した。
例データ
Ａ１１：Ｈ１１
432 1123 567 738 382 976 1314 5532（横合計）
第１２行とＩ列は空白とする。ＣｕｒｒｅｎｔＲｅｇｉｏｎのため。
Ｈ１３にターゲット値　５５００　を入れている。
'---
コード（標準モジュール）
Sub test01()
r = Range("a1").CurrentRegion.Rows.Count '区画の行数
c = Range("a1").CurrentRegion.Columns.Count '区画の列数
MsgBox r & "行" & c & "列" '最下行、最右行は合計とする
Cells(15, c) = 0
For i = 1 To c - 1 '各列について
x = WorksheetFunction.Round(Cells(r, i) * Cells(13, c) / Cells(r, c), 3) '小数以下３位まで
Cells(14, i) = x
x = x - Int(x) '少数以下端数
Cells(16, i) = x
Cells(15, i) = WorksheetFunction.Round(Cells(r, i) * Cells(13, c) / Cells(r, c), 0) '整数値
Cells(18, i) = Cells(15, i)
Cells(15, c) = Cells(15, c) + Cells(15, i) '集計列に足しこみ
Cells(16, i) = Abs(Cells(15, i) - Cells(14, i)) '差の絶対値
Next i
'---
For i = 1 To c - 1
Cells(17, i) = WorksheetFunction.Rank(Cells(16, i), Range("A16:G16"), 0) 'ランク設定
Next i
'-----
d = Abs(Cells(13, c) - Cells(15, c)) '合計差額整数
If Cells(13, c) - Cells(15, c) > 0 Then s = -1 Else s = 1 '大小サイン
For i = 1 To d '超過不足数だけ１を足し引きし調整繰り返し
y = Range("A17:G17").Find(what:=i).Column 'ランク上位から順に探す
Cells(18, y) = Cells(15, y) - s * 1 '調整
Next i
End Sub
結果（元データも含む）
途中経過がわかるように各行にデータを出している。
Ａ１１：Ｈ１８
432 1123 567 738 382 976 1314 5532

5500
429.501 1116.504 563.72 733.731 379.79 970.354 1306.399
430 1117 564 734 380 970 1306 5501
0.499 0.496 0.28 0.269 0.21 0.354 0.399
1 2 5 6 7 4 3
429 1117 564 734 380 970 1306 5500
多数例でチェック出来なかったので、バグがあるかもしれない。
H13を変えてやってみてください。
本番ではセルの変わりに配列に中間結果の値を入れて、最終結果の
第１８行を出力し使用にすると良い。
またコマンドボタン等で起動するようにするとよいと思う。
既に長大なご回答が出たあとで、そちらの理解が精一杯で、こちらは考えて見る余力もないかもしれないが、一応上げておきます。

お礼

imogasiさん、いつもありがとうございます。
勉強します。

回答No.3

Wendy02

merlionXX さん、こんにちは。
Wendy02です。

＞高度な内容なので時間をかけて研究させていただきます。
いいえ、この内容は初歩的です。

#1 さんの案を考えたのですが、深夜で、とても気力がなかったからです。ただし、これだけの数になると、大変な時間が掛かります。Excelアドインのソルバー自体は、過去のものなので、VBAのほうがはやいです。でも、コードがとても面倒です。

＞ところで、どうして±10%が限度なのでしょうか？
その数字に根拠はありません。ただ、50% ならともかく、90% 増減だとしたら、何を案分しているのか意味がなくなるような気がしたからです。

これは、GTotal(手でいれた総計）と実際のSum(範囲）との差が、あまりに差がありすぎるときは、おそらくは、GTotalの入力を疑ったほうが良いということです。マクロで行うと、その結果は、不可逆ですから、一気に、マクロを走らせないほうがよい、と考えました。

私のコードの中の最大値からの修正

行で処理する場合

（後で考えてみましたが、Excelの特質で、行のほうが、縦よりも、若干、マクロが走りやすく書きやすいです。それは、マクロは、高スピードで、横に走って、次の行に行くようになっています。そういう造りになっています。それに合わせてあげたほうがよいです。）

以下を書き換えればよいと思います。
論理的には同じ考え方です。
Match関数で、最大セルを探すか、Find メソッドで最大セルを探すか、そのどちらかです。その後、最大セルの次の値に及ばせる場合は、Large関数を使えばよいわけです。

rng は、一行です。

Diff = WorksheetFunction.Sum(rng) - PostTotal
　i = WorksheetFunction.Match(WorksheetFunction.Max(rng), rng, 0)
　rng.Cells(1, i).Value = rng.Cells(1, i).Value - Diff

全体からする場合　Gtotal は、Grand Total
これを、最大値から順に振り分けていきます。
=LARGE($A$1:$G$10,x)
ここは、単に、Max だけでも良いと思います。Loop を使うのは、1回で終われるのか、確実性がなかったからです。

　 Do Until WorksheetFunction.Sum(myRng) - GTotal.Value = 0
　　　x = x + 1
　　　Set RMax = myRng.Find(WorksheetFunction.Large(myRng, x), LookIn:=xlValues)
　　　RMax.Value = RMax.Value - _
　　　(WorksheetFunction.Sum(myRng.Value) - GTotal.Value)
　 Loop

とりあえず、こんな所といたします。

お礼

ありがとうございます。
Wendy02さんには初歩的でもわたしには至って高度なのでとりあえず下記の方法で対応しました。
有難うございました。

Sub TEST01()

Dim c As Range
Dim base As Integer, goal As Integer
Dim rtio As Double
base = Range("base").Value
goal = Range("base").Offset(, 1).Value
rtio = goal / base

For Each c In Range("DATA")
c.Value = Application.WorksheetFunction.Round(c.Value * rtio, -1)
Next

df = goal - Range("base").Value
If df <> 0 Then

mx = Application.WorksheetFunction.Max(Range("DATA"))

For Each c In Range("DATA") 'Range("DATA")の中で最大の値+df
If c.Value = mx Then
c.Value = c.Value + df
Exit For
End If
Next
End If

End Sub

回答No.2

Wendy02

merlionXX　さん、こんばんは。
Wendy02です。

これは、単に、案分で差額を入れていくのなら、対して頭は使いませんね。上から修正していけばよいのですから。ソルバーとなったら、ちょっと大変です。最初、マクロでソルバーを考えましたが、面倒なのと、その考え方が総あたり制なので、方法が全然違います。

ただし、作った後で気が付いたのですが、「2.各列の縦計」は、あまり関係がありませんね。結果で、縦であろうが横であろうが、計算が合わなければ話になりませんからね。というか、横で計算をしてしまったから言い訳です。（^^;

＞H11のセルの総合計の数値を、任意の値に変えた場合、
＞それ以外の数値を、その割合で増減させ、
＞下二桁めは四捨五入したいのです。

の三つの要件が揃っていればよいわけです。

なお、増減の割合は、今は10%以上は、動きません。これは、Excelならではのコードですね。

'-------------------------------------------------

Sub ReArrangeTotal()
　 Dim myRng As Range
　 Dim GTotal As Range
　 Dim VTotal(9) As Double
　 Dim VTotalRng As Range
　 Dim PreTotal As Double
　 Dim Ratio As Double
　 Dim i As Long
　 Dim k As Long
　 Dim n As Long
　 Dim RMax As Range
　 Dim x As Integer
　 Set myRng = Range("A1:G10")

　 Set GTotal = myRng.Cells(myRng.Count).Offset(1, 1)
　 Set VTotalRng = myRng.Offset(, myRng.Columns.Count).Resize(, 1)
　 For i = 1 To myRng.Rows.Count
　　　VTotal(i - 1) = VTotalRng.Cells(i).Value
　 Next i

　 PreTotal = WorksheetFunction.Sum(VTotal)
　 '最後の集計と元の比較のため、総合計の下に出しておく。
　 GTotal.Offset(1).Value = GTotal.Value

　 '割合のチェック(10%以上はストップ)
　 Ratio = GTotal.Value / PreTotal
　 If Ratio = 1 Then MsgBox "修正の必要ありません。": Exit Sub
　 If Abs((PreTotal - GTotal.Value) / PreTotal) > 0.1 Then MsgBox "差が大きすぎます。": Exit Sub

　 '値の確保
　 For k = 1 To 10
　　　VTotalRng.Cells(k).Value = _
　　　WorksheetFunction.Round(VTotal(k - 1) * Ratio, -1)
　 Next k

　 '行修正
　 For n = 1 To 10
　　　ArrangeRatio myRng.Rows(n), VTotal(n - 1), VTotalRng.Cells(n)
　 Next n

　 VTotalRng.FormulaLocal = "=SUM(" & myRng.Rows(1).Address(0, 0) & ")"

　 '全体範囲修正
　 Do Until WorksheetFunction.Sum(myRng) - GTotal.Value = 0
　　　x = x + 1
　　　Set RMax = myRng.Find(WorksheetFunction.Large(myRng, x), LookIn:=xlValues)
　　　RMax.Value = RMax.Value - _
　　　(WorksheetFunction.Sum(myRng.Value) - GTotal.Value)
　 Loop
　 GTotal.FormulaLocal = "=SUM(" & myRng.Address(0, 0) & ")"

　 Set GTotal = Nothing: Set VTotalRng = Nothing
　 Set myRng = Nothing
End Sub

Sub ArrangeRatio(rng As Range, PreTotal As Double, PostTotal As Double)
Dim c As Range
Dim Diff As Double
Dim myRatio As Double
Dim i As Long
　myRatio = PostTotal / PreTotal
　For Each c In rng.Cells
　　c.Value = WorksheetFunction.Round(c.Value * myRatio, -1)
　Next c
　Diff = WorksheetFunction.Sum(rng) - PostTotal
　i = WorksheetFunction.Match(WorksheetFunction.Max(rng), rng, 0)
　rng.Cells(1, i).Value = rng.Cells(1, i).Value - Diff
End Sub

お礼

Wendy02さん、いつもありがとうございます。

高度な内容なので時間をかけて研究させていただきます。
ところで、どうして±10%が限度なのでしょうか？

補足

すみません、せっかく教えていただいたのですが先ほど上司から指示があり、端数はデータ中の最大の値から差し引きして調整するということになりました。
作って見たのですが、「最大の・・・」でつまずいています。

Sub TEST01()
'Dim DATA As Range
Dim base As Integer, goal As Integer, df As Integer
Dim rtio As Double
base = Range("base").Value
goal = Range("base").Offset(, 1).Value
rtio = goal / base

For Each c In Range("DATA")
c.Value = Application.WorksheetFunction.Round(c.Value * rtio, -1)
Next

df = goal - base

If df <> 0 Then

'Range("DATA")の中で最大の値－df・・・この部分がわかりません。（泣）

End If
End Sub

よろしくお願いします。

回答No.1

noname#262398

アドインのソルバーが役に立つかもしれません。
詳しいことはヘルプをごらん頂くとして、もし実際に使うなら、
まず、データを全て1/10にします。
A11:G11をA12:G12に値コピペして、H12 =SUM(A12:G12)
[ツール]-[ソルバー]
[目的セル] H12、[目標値] 5500、[変化させるセル] A12:G12、[制約条件] A12:G12=整数
[オプション]を設定して[実行]
これで、縦計の最適値(の1/10)が求まります。
そうしたら今度は、その値を目標値として、各列に対して実行。
最後にデータを10倍します。

試しにやってみましたけど、完璧な解では無かったです。
設定が悪かったのかもしれませんが。
これをVBAでやるとなると？？？？？？

お礼

ありがとうございます。
ソルバーというのがあるのですね、不勉強で手が出ません（泣）