エクセル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.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