EXCELで少し複雑な条件の計算をしたいのです

質問

出来れば自動化出来ないか、と思いお知恵をお借りしたく投稿させて頂きました。
ソフトはMS Excel XPです。

やりたい事は、

　前提
・A1に加算上限個数として「30」という数値が入っているとします。
・B列にはB1～B50まで金額がソートされていない状態で入っているとします
・C列にはC1～C50までB列の物の個数が入っているとします。

金額の高い物から順番に、A1の30個分金額を加算し、A2に表示する事は可能でしょうか？

どんな方法でも結構ですので、もし可能であれば、ご教授をお願い致します。

回答No.1

ka_na_de · ベストアンサー

こんばんは。
一例です。

(1)Ａ２セルに
　=SUM(INDIRECT("D1:D"&A1))
　と入力

(2)「Alt」＋「Ｆ11」でＶＢＥを起動して、
シートモジュールに以下をコピペしてください。

'=======シートモジュールに記述（コピペ）してください===========
Private Sub Worksheet_Change(ByVal Target As Range)
　　On Error GoTo Err_
　　Dim myLastRow As Long, myNum As Long
　　Dim i As Long, j As Long, m As Long

　　If Target.Column = 4 Then Exit Sub

　　myLastRow = Cells(Rows.Count, "B").End(xlUp).Row
　　Columns("D:D").Clear

　　m = 1
　　For i = 1 To myLastRow
　　　　If Cells(i, "C").Value >= 1 Then
　　　　　　For j = 1 To Cells(i, "C").Value
　　　　　　　　If IsNumeric(Cells(i, "B").Value) Then
　　　　　　　　　　Cells(m, "D").Value = Cells(i, "B").Value
　　　　　　　　　　m = m + 1
　　　　　　　　End If
　　　　　　Next j
　　　　End If
　　Next i

　　With Columns("D:D")
　　　　.Sort Key1:=Range("D1"), Order1:=xlDescending, Header:=xlGuess
　　　　.EntireColumn.Hidden = True
　　End With
Bye_:
　　Exit Sub
Err_:
　　MsgBox Err.Description, vbCritical
　　Resume Bye_
End Sub

お礼

すみません、自己解決できました。
無事やりたい事が完璧に出来ました。
ありがとうございました。

補足

ka_na_deさま
ありがとうございます、何とか参考に自力で解決したかったのですが、
つまづいてしまいました。

A列に金額、B列も同様で、D列に個数が入っております。
最終的にはB列も同様の処理を行いたいと思っております。
(数値は別の場所から「=E3」の様に参照しております)

－－－
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Err_
Dim myLastRow As Long, myNum As Long
Dim i As Long, j As Long, m As Long

If Target.Column = 4 Then Exit Sub

myLastRow = Cells(Rows.Count, "A").End(xlUp).Row
Columns("E:E").Clear

m = 1
For i = 1 To myLastRow
If Cells(i, "D").Value >= 1 Then
For j = 1 To Cells(i, "D").Value
If IsNumeric(Cells(i, "A").Value) Then
Cells(m, "E").Value = Cells(i, "A").Value
m = m + 1
End If
Next j
End If
Next i

With Columns("E:E")
.Sort Key1:=Range("E1"), Order1:=xlDescending, Header:=xlGuess
.EntireColumn.Hidden = True
End With

Bye_:
Exit Sub
Err_:
MsgBox Err.Description, vbCritical
Resume Bye_
End Sub
－－－

の様に改造してみたのですが、永久ループにはまってしまう様です。
何が原因か分からず困っております。
お知恵をお借りできませんでしょうか。