[[20051011093820]]　『金種マクロ』（純丸）　ページの最後に飛ぶ

『金種マクロ』（純丸）

 以前、↓金種関数を作りましたが、一気に出すマクロを作ってみました。
[[20050423175641]]『金種関数』（純丸）
 突っ込み、お待ちしております。
（純丸）(o^-')b

 Option Explicit

 Sub kinshu()

 Dim myr As Range
 Dim myvalue As Long
 Dim hani As Range
 Dim uwagaki As String
 Dim shuturyoku As Range
 Dim maisu(8) As Long
 Dim kinshu As Variant
 Dim i As Integer

 On Error Resume Next

 kinshu = Array("10000", "5000", "1000", "500", "100", "50", "10", "5", "1")
 Set hani = Application.InputBox(prompt:="金額範囲を入力して下さい", Title:="範囲指定", Type:=8)
 再度:
 Set shuturyoku = Application.InputBox(prompt:="出力先頭セルを入力して下さい", _
                  Default:=ActiveCell.Address, Title:="出力先指定", Type:=8)
 If shuturyoku.Count <> 1 Then GoTo 再度

 If Not shuturyoku.Resize(12, 3).Find("*") Is Nothing Then
    shuturyoku.Resize(12, 3).Select
    uwagaki = MsgBox("出力範囲にデータがあります。上書きしてよろしいですか？", vbYesNo, "上書き確認")
    If uwagaki = vbNo Then
       shuturyoku.Select
       GoTo 再度
    End If
 End If

 For Each myr In hani
   myvalue = myr.Value
   For i = 0 To 8
     maisu(i) = maisu(i) + Int(myvalue / kinshu(i))
     myvalue = myvalue Mod kinshu(i)
     If myvalue <= 0 Then Exit For
   Next i
 Next myr

 With shuturyoku
    .Select
    .Offset(0, 0).Value = "金　種"
    .Offset(0, 1).Value = "枚　数"
    .Offset(0, 2).Value = "金　額"
   For i = 1 To 9
    .Offset(i, 0).Value = kinshu(i - 1)
    .Offset(i, 1).Value = maisu(i - 1)
    .Offset(i, 2).FormulaR1C1 = "=(RC[-2]*RC[-1])"
   Next i
    .Offset(11, 2).FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
 End With

 End Sub

 何で中止できないの？

 Dim shuturyoku As Range
 On Error Resume Next
 Do
   Set shuturyoku = Nothing
   Set shuturyoku = Application.InputBox(prompt:="出力先頭セルを入力して下さい", _
                  Default:=ActiveCell.Address, Title:="出力先指定", Type:=8)
   If shuturyoku Is Nothing Then
      MsgBox "中止"
      Exit Sub
   ElseIf shuturyoku.Count > 1 Then
      MsgBox "XXXXXX"
   Else
      Exit Do
   End If
 Loop
 BJ

 確かに InputBox のキャンセルボタンの事を全然考えていませんでした。
 と言うことで改良版です。BJさん、ありがとう。m(__)m
（純丸）(o^-')b

 Option Explicit

 Sub kinshu()

 Dim myr As Range
 Dim myvalue As Long
 Dim hani As Range
 Dim uwagaki As String
 Dim shuturyoku As Range
 Dim maisu(8) As Long
 Dim kinshu As Variant
 Dim i As Integer

 On Error Resume Next

 kinshu = Array("10000", "5000", "1000", "500", "100", "50", "10", "5", "1")
 Set hani = Application.InputBox(prompt:="金額範囲を入力して下さい", Title:="範囲指定", Type:=8)
   If hani Is Nothing Then
      MsgBox "中止します"
      Exit Sub
   End If
 再度:
 Set shuturyoku = Nothing
 Set shuturyoku = Application.InputBox(prompt:="出力先頭セルを入力して下さい", _
                 Default:=ActiveCell.Address, Title:="出力先指定", Type:=8)
 If shuturyoku Is Nothing Then
       MsgBox "中止します"
       Exit Sub
 End If
 If shuturyoku.Count > 1 Then
    MsgBox "一つのセルを選んで下さい"
    GoTo 再度
 End If
 If Not shuturyoku.Resize(12, 3).Find("*") Is Nothing Then
    shuturyoku.Resize(12, 3).Select
    uwagaki = MsgBox("出力範囲にデータがあります。上書きしてよろしいですか？", vbYesNo, "上書き確認")
    If uwagaki = vbNo Then
       shuturyoku.Select
       GoTo 再度
    End If
 End If

 For Each myr In hani
   myvalue = myr.Value
   For i = 0 To 8
     maisu(i) = maisu(i) + Int(myvalue / kinshu(i))
     myvalue = myvalue Mod kinshu(i)
     If myvalue <= 0 Then Exit For
   Next i
 Next myr

 With shuturyoku
    .Select
    .Offset(0, 0).Value = "金　種"
    .Offset(0, 1).Value = "枚　数"
    .Offset(0, 2).Value = "金　額"
   For i = 1 To 9
    .Offset(i, 0).Value = kinshu(i - 1)
    .Offset(i, 1).Value = maisu(i - 1)
    .Offset(i, 2).FormulaR1C1 = "=(RC[-2]*RC[-1])"
   Next i
    .Offset(11, 2).FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
 End With

 End Sub

 こんばんわ。

 shuturyoku.Resize(12, 3)....

を

 shuturyoku.Cells(1,1).Resize(12, 3)....

 とすれば、

 If shuturyoku.Count > 1 Then
    MsgBox "一つのセルを選んで下さい"
    GoTo 再度
 End If

 は、要りません。

 ついでに、

 With shuturyoku
    .Select
    .Offset(0, 0).Value = "金　種"
    .Offset(0, 1).Value = "枚　数"
    .Offset(0, 2).Value = "金　額"
   For i = 1 To 9
    .Offset(i, 0).Value = kinshu(i - 1)
    .Offset(i, 1).Value = maisu(i - 1)
    .Offset(i, 2).FormulaR1C1 = "=(RC[-2]*RC[-1])"
   Next i
    .Offset(11, 2).FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
 End With

 の部分は、以下のようになりますか？

 With shuturyoku.Cells(1, 1)
    .Resize(, 3) = Array("金　種", "枚　数", "金　額")
    .Offset(1, 1).Resize(UBound(kinshu) + 1) = Application.Transpose(kinshu)
    .Offset(1, 2).Resize(UBound(maisu) + 1) = Application.Transpose(maisu)
    .Offset(1, 3).Resize(UBound(maisu) + 1).FormulaR1C1 = "=(RC[-2]*RC[-1])"
    .Offset(11, 2).FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
 End With
 (seiya)

 seiyaさん、ありがとうございます。勉強になります。
 >shuturyoku.Cells(1,1).Resize(12, 3).... とすれば、
 の部分はよくわかりました。複数セルを入力しても、範囲の左上の
 セルを取得することによって問題なしとする訳ですね。

 With 以下の部分ですが、配列についてはまだよくわかっておらず
 一気に展開することには思い至りませんでした。
 配列の要素数は9で固定なので、

 With shuturyoku.Cells(1, 1)
    .Resize(, 3) = Array("金　種", "枚　数", "金　額")
    .Offset(1, 0).Resize(9) = Application.Transpose(kinshu)
    .Offset(1, 1).Resize(9) = Application.Transpose(maisu)
    .Offset(1, 2).Resize(9).FormulaR1C1 = "=(RC[-2]*RC[-1])"
    .Offset(11, 2).FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
 End With

 と、してみましたが、UBound を使わなければならない理由がありますか？
（尚、ご提示いただいたコードでは、Offsetの列の指定が
 １つずつずれていました。）
（純丸）(o^-')b

 おはようございます。

 >UBound を使わなければならない理由がありますか？

 ありません。kinshuの要素数を確認していなかったもので.....

 >Offsetの列の指定が１つずつずれていました。

 お許しを....

 参考までに、配列を使用した場合の出力は出来る限り一気にしたほうが
より高速になるようです。ご存知のように、オブジェクトにアクセスする
回数が多いほど遅くなるわけですので。
不要なSelectも同様です。（ほとんどのケースでSelectは必要ありません）
(seiya)

 おはようございます。配列の出力についてはよく理解出来ます。
 もちろん Select についても承知していますが、今回は、出力後に
 出力範囲の先頭セルをアクティブにした方がいいと思い、Select を
 １行入れた次第です。
 いろいろとありがとうございました。m(__)m
（純丸）(o^-')b

 純丸さん、おはようございます。
 突っ込むことが出来ないので、σ(^o^;)なりに作ってみました。
 ちょっと、無駄がありそうな気がしますが・・・

 kisyu(a1)
 などと入力。
 シートモジュールへ 
'--------------------------
Option Base 1
Private Sub Worksheet_Change(ByVal Target As Range)
Dim kin As Long, kei As Long
Dim MyA As Variant
Dim MyAry(1 To 11, 1 To 2) As Variant
Dim hani As Range, tbl As Range
Dim data As Variant
Dim sdrs As String
Dim i As Long, r As Long

adrs = Target.Address

    If Target.Count <> 1 Then: Exit Sub
    If Left(Range(adrs), 7) <> "kinsyu(" Then: Exit Sub
    data = Split(Range(adrs).Value, "(")(1)
    If data = "" Then: Exit Sub
    data = Left(data, Len(data) - 1)
    Application.EnableEvents = False
    Target = ""
    If Not Range(adrs).Resize(12, 3).Find("*") Is Nothing Then
        Range(adrs).Resize(12, 3).Select
        If MsgBox("出力範囲にデータがあります。上書きしてよろしいですか？", vbYesNo, "上書き確認") = vbNo Then
            MsgBox "中止しました"
            Application.EnableEvents = True: Exit Sub
        End If
        Selection.ClearContents
    End If
    For Each tbl In Range(data)
        kin = kin + tbl
    Next tbl
    MyA = Array("10000", "5000", "1000", "500", "100", "50", "10", "5", "1")
    For r = 1 To 9
        i = i + 1
        MyAry(r, 1) = Int(kin / MyA(i))
        MyAry(r, 2) = MyAry(r, 1) * MyA(i)
        kin = kin - MyAry(r, 2)
        kei = kei + MyAry(r, 2)
    Next r
    MyAry(11, 2) = kei
    Cells(Range(adrs).Row + 1, Range(adrs).Column).Resize(9, 1) = Application.Transpose(MyA)
    Range(adrs).Resize(, 3) = Array("金　種", "枚　数", "金　額")
    Cells(Range(adrs).Row + 1, Range(adrs).Column + 1).Resize(11, 2) = MyAry
    Application.EnableEvents = True
End Sub

 （キリキ）（〃⌒o⌒)b

 やっと検証出来ましたぁ。キリキさん提唱の Changeイベントですね。
 使い道によってはイベントの方が使い勝手がいいかもです。
 セルに一生懸命 kinshu(A1:A10) と入力しても何もおこらず、
 ？と思っていたのですが、よく見たら kinsyu でした。 （^^; アセアセ
（純丸）(o^-')b　やっと会議終了

 会議ご苦労様ですm(_ _)m

 >よく見たら kinsyu でした。
 ありゃりゃ、こちらも良く見たら
 純丸さんのは、「kinshu」でしたね・・・
 すんませんでした～

 （キリキ）(〃⌒o⌒)b

コメント返信：

[ 一覧(最新更新順) ]

[[20051011093820]] 『金種マクロ』（純丸） ページの最後に飛ぶ

[[20051011093820]]　『金種マクロ』（純丸）　ページの最後に飛ぶ