エクセル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.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さん、いつもありがとうございます。
勉強します。