ドント方式をExcel関数にすると・・・

質問

各店舗の人員構成比が下記のようになっているとします（％）↓

A店：56.9
B店：12.5
C店：30.6

これを人数として出したいので、下記のように小数点以下を調整する作業をExcelの関数でできないでしょうか？

A店：57
B店：12
C店：31

四捨五入をすると、全体が100を超えてしまいます。
比例代表制の選挙配分として使われている「ドント方式」になると思うのですが、
これをExcelの関数で出すことができればご教授ください。

回答No.6

BLUEPIXY · ベストアンサー

'愚直にドント方式百分率配分をどーんとプログラムしてみました
Public Sub どーんと実行()
'dont(入力データ範囲,出力データ範囲)
Call donto(Range("A1:C1"), Range("A2:C2"))
End Sub

'入力データは１００分率
'dont(入力データ範囲,出力データ範囲)
Public Sub donto(s As Range, d As Range)
Dim data() As Double, count() As Integer, dataKind As Integer
Dim i As Integer, j As Integer, x As Range, maxV As Double, maxI As Integer, sum As Integer
dataKind = s.count 'データの分類数
ReDim data(100, dataKind)
ReDim count(dataKind)

i = 0
For Each x In s
i = i + 1
count(i) = 0
data(0, i) = x.Value
Next
For i = 1 To 100
For j = 1 To dataKind
data(i, j) = data(0, j) / i 'ドント表の作成
Next
Next

Do While True
maxV = 0#
For j = 1 To dataKind '最大値を求める
If data(count(j) + 1, j) > maxV Then '０％のデータは無い
maxV = data(count(j) + 1, j)
maxI = j
End If
Next
count(maxI) = count(maxI) + 1 '最大値の件数を１増やす

sum = 0
For j = 1 To dataKind '合計を求める
sum = sum + count(j)
Next
If sum = 100 Then Exit Do
Loop
'出力に設定
i = 0
For Each x In d
i = i + 1
x.Value = count(i)
Next
End Sub

お礼

ありがとうございます！
試す時間を少しください。

回答No.7

Wendy02

こんばんは。

試しにちょっと考えてみました。
これは、最大値から割り振る方式にしています。一般的なものならうまくいくはずです。（注意すべき点:コードの下のサンプルをご覧ください。）

'<シートモジュール>
'コントロールツールバーから、コマンドボタンをクリックして、ワークシートに書いたら、右クリックで、[コードの表示]をクリックして、以下を貼り付けます。

'---------------------------------------
Option Explicit
Private Sub CommandButton1_Click()
　 '上位から差分を加算または、減算する方式
　 Dim rng As Range
　 Dim Destine As Range '出力先
　 Dim Ar() As Double
　 Dim RangeTotal As Double
　 Dim PercentTotal As Double
　 Dim LargeCount As Integer
　 Dim ret As Integer
　 Dim buf As Double
　 Dim c As Range
　 Dim i As Long
　 Dim j As Long

　 '以下の精度(ACCURACY)は、1 か、0.1 を入れます。
　 Const ACCURACY As Double = 1

　 If Not (ACCURACY = 1 Or ACCURACY = 0.1) Then MsgBox "このプログラムでは、精度(ACCURACY)は、1 か、0.1 のみです。": Exit Sub
　 'マウスで範囲を選択します。
　 On Error Resume Next
　 Set rng = Application.InputBox("範囲を選択してください。", Type:=8)
　 If rng Is Nothing Then Exit Sub
　 Set Destine = Application.InputBox("出力先を指定してください。" & vbCrLf & _
　 "先頭の一番上にセルだけでよいです。", Type:=8)
　 On Error GoTo 0
　 If Err() > 0 Then Exit Sub
　 '
　 RangeTotal = WorksheetFunction.Sum(rng)
　 ReDim Ar(0 To rng.Count - 1)
　 For Each c In rng
　　　If VarType(c) = vbDouble Then
　　　　 Ar(i) = Int((c.Value / RangeTotal) * 100 * (1 / ACCURACY) + 0.5) / (1 / ACCURACY)
　　　　 i = i + 1
　　　End If
　 Next c
　 PercentTotal = WorksheetFunction.Sum(Ar())
　 If 100 - PercentTotal <> 0 Then
　　　LargeCount = (100 - PercentTotal) / ACCURACY
　　　If Int(LargeCount) > rng.Count Then MsgBox "このプログラムでは修正不可能です。", 16: Exit Sub
　　　For j = 1 To Abs(Int(LargeCount))
　　　　 buf = WorksheetFunction.Large(Ar, j)
　　　　 ret = WorksheetFunction.Match(buf, Ar(), 0)
　　　　 Ar(ret - 1) = buf + Sgn(LargeCount) * ACCURACY
　　　Next j
　 End If
　 PercentTotal = WorksheetFunction.Sum(Ar())
　 If CInt(PercentTotal * (1 / ACCURACY)) <> 100 * (1 / ACCURACY) Then MsgBox "修正に失敗しました。", 16: Exit Sub
　 '合計式の代入
　 With rng
　　　If .Rows.Count > .Columns.Count Then
　　　　 Destine.Cells(1, 1).Resize(.Rows.Count, .Columns.Count).Value = _
　　　　 WorksheetFunction.Transpose(Ar())
　　　　 Destine.Offset(.Rows.Count).FormulaLocal = "=SUM(" & Destine.Cells(1, 1).Resize(.Rows.Count, .Columns.Count).Address & ")"
　　　　 Else
　　　　 Destine.Cells(1, 1).Resize(.Rows.Count, .Columns.Count).Value = Ar()
　　　　 Destine.Offset(, .Columns.Count).FormulaLocal = "=SUM(" & Destine.Cells(1, 1).Resize(.Rows.Count, .Columns.Count).Address & ")"
　　　End If
　 End With
　 If WorksheetFunction.Max(Ar()) < 10 And ACCURACY = 1 Then
　　　MsgBox "この出力は精度(ACCURACY)がふさわしくないかもしれません。" & vbCrLf & _
　　　"VBEを開けて、ACCURACY を0.1 にすると良いかもしれません。", 32
　 End If
End Sub

'=====================================
精度が0.1が必要な場合。

　　　精度1　　　　 精度0.1
265　　　6　'←矛盾　7.9
220　　　7　　　　　 6.5
174　　　5　　　　　 5.1
31　　　 1　　　　　 0.9
202　　　6　　　　　 6
252　　　7　　　　　 7.4
184　　　5　　　　　 5.4
167　　　5　　　　　 4.9
187　　　6　　　　　 5.5
23　　　 1　　　　　 0.7
207　　　6　　　　　 6.1
39　　　 1　　　　　 1.2
130　　　4　　　　　 3.8
175　　　5　　　　　 5.2
285　　　8　　　　　 8.5
63　　　 2　　　　　 1.9
229　　　7　　　　　 6.8
64　　　 2　　　　　 1.9
123　　　4　　　　　 3.6
226　　　7　　　　　 6.7
24　　　 1　　　　　 0.7
17　　　 1　　　　　 0.5
96　　　 3　　　　　 2.8
------- ----　　　　-----
3338　 100　　　　　100

また、このようなデータ数ですと、精度を0.1にしないと矛盾が起きてしまいます。

なお、表示は、1桁と0.1 の小数点第一位までです。必要な場合は、コードの中のACCURACY(精度）の数字を0.1に変更してください。また、エラー値を含むと、現在のコードでは正しく修正されません。

回答No.5

merlionXX

No2です。

> 各店の人員数は分かります。

ええっ！？

> これを人数として出したいので

とお書きになっていましたよね？

では、何を求めればいいのでしょう？
ひょっとして構成比を整数で出したいということですか？
それなら
=ROUND(各店の人数／全体の人数*100,0)です。

合計が100にならない場合は最大の構成比の店で調整します。

お礼

>合計が100にならない場合は最大の構成比の店で調整します。

この調整部分をドント方式に法り算出できないかと思い、質問しました。
“ドント方式”ってところに意味があり、四捨五入では意味がないのです。
説明不足で済みません。

回答No.4

Wendy02

こんにちは。

私は、社内の統計資料なら問題ないので、手を加えていましたね。「偽造」ではありませんが、+1/-1　とかしていましたね。自動化するというのは、できる出来ないは別として、私の仕事感覚で出来ませんでした。それは、万が一に、その計算を追及されたときに、実は、こういうようなことをしたのだと、1年後にみても、自分で説明つくようにしていました。

回答No.3

BLUEPIXY

関数では、他の関数の結果による配分というのができないように思います。
やるとしたらマクロになると思います。

お礼

ご回答ありがとうございます。
マクロの方法をご教授いただけますでしょうか。

回答No.2

merlionXX

各店の人員数がわかって初めて構成比が出せるのだと思いますが・・・・。

まあ、何らかの事情で％から人数の近似値を求めなくてはならないわけですね？

こうしたらいかがでしょう？

=ROUND(人員総数×構成比／100,0)

で、四捨五入のため各店を合計したら、人員総数と一致しない場合がありますので、その場合は一番大きい店で調整します。

お礼

>まあ、何らかの事情で％から人数の近似値を求めなくてはならないわけですね？

構成比で説明した方が、分かり易いかと思っただけで、各店の人員数は分かります。
説明が至らず済みません。

回答No.1

noname#123709

書かれている内容はドント方式の話ではないような気がしますが・・・。
ドント方式は公平に・・・ですよね。
質問者様が書かれている例で言えば、割合を出す時に各店の人数が先に分か
っているはずなんですけど。
ドント方式をExcel関数に・・の回答でなくて申し訳ないですが・・・。

お礼

>質問者様が書かれている例で言えば、割合を出す時に各店の人数が先に分か
>っているはずなんですけど。

説明不足で済みません！
人数は分かってます！！人数からの計算になるのでしょうか？