[[20181007031515]]　『答えを任意セルに記入』（山口）　ページの最後に飛ぶ

『答えを任意セルに記入』（山口）

よろしくお願いします。

   A     ・　　・　F
○○製品           5
□○版             2
△製品             8
以下のマクロで得られる数値は「13」（MsgBoxで表示）ですが、表示後
これを任意のセルをクリックして貼り付ける方法をご教授お願いします。
Sub 品名別集計()
   Dim i As Variant

   i = Application.InputBox( _
            Title:="数量算出【Ａ列】", _
            Prompt:="検索文字列を入力しなさい。" & vbCrLf & "ある文字を含む項目の合計を算出します。" & vbCrLf & "集計範囲はA67～A4500" & vbCrLf & "※注意" & vbCrLf & "上記範囲以外は別集計", _
            Default:="製品（例として）", _
            Left:=50, _
            Top:=150, _
            Type:=2)
 If VarType(i) = vbBoolean Then
'If i = "" Or i = False Then
'   If i = "" Then
      Exit Sub
   End If
MsgBox Format(WorksheetFunction.SumIf(Range("A67:A4500"), "*" & i & "*", Range("F67:F4500")), "#,##0")
End Sub

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

レンジオブジェクトのシート指定は敢えてしていませんが。なさった方が良いかと。。。
必要な分だけ足した感じです。アドレスＡ１～、Ｆ１～に変えましたが適切な値に変えてくださいね。

Option Explicit
Sub 品名別集計()

   Dim i As Variant
   Dim ans As Long
   Dim rngtx As String
   i = Application.InputBox(Title:="数量算出【Ａ列】", _
                            Prompt:="検索文字列を入力しなさい。" & vbCrLf & _
                            "ある文字を含む項目の合計を算出します。" & _
                            vbCrLf & "集計範囲はA67～A4500" & vbCrLf & _
                            "※注意" & vbCrLf & "上記範囲以外は別集計", _
                            Default:="製品（例として）", _
                            Left:=50, _
                            Top:=150, _
                            Type:=2)
    If VarType(i) = vbBoolean Then
          'If i = "" Or i = False Then
          '   If i = "" Then
          Exit Sub
    End If
    'MsgBox Format(WorksheetFunction.SumIf(Range("A67:A4500"), "*" & i & "*", Range("F67:F4500")), "#,##0")
    ans = Format(WorksheetFunction.SumIf(Range("A1:A4500"), "*" & i & "*", Range("F1:F4500")), "#,##0")
    i = Application.InputBox(Title:="数量算出結果【Ｆ列】＝　" & ans, _
                            Prompt:="出力先を入力して下さい。" & _
                            vbCrLf & "集計範囲はA67～A4500" & vbCrLf & _
                            "※注意" & vbCrLf & "上記範囲以外は別集計", _
                            Default:="H2", _
                            Left:=50, _
                            Top:=150, _
                            Type:=2)
    If VarType(i) = vbBoolean Then
          'If i = "" Or i = False Then
          '   If i = "" Then
        Exit Sub
    End If
    Range(i) = ans
    Application.Goto Range(i)
End Sub
（隠居じーさん） 2018/10/07(日) 09:11

追伸
Dim rngtx As String 。。。使っていないですね　＾＾；
間違いです。無しに修正お願いいたします。
済みません
m(_ _)m
でわ

（隠居じーさん） 2018/10/07(日) 09:17

隠居じーさん）さん
ありがとうございます。
早速実行してみたのですが
以下の部分で止まります。

    Range(i) = ans
ただし、
Default:="H2"
デフォルト　H2　のままはOKなのですが
ここで別セルをクリックし、セル指定するとエラー
rangeメソッドは失敗しました
対策は、ありますか？

（山口） 2018/10/07(日) 12:50

はい！
クリックして選択ではなく。
小文字でもよいので
ｇ36
ｎ1
とかセル番地を手入力してください
クリックが良ければ。。。（済みません。。ご希望でしたよね　＾＾）
めんど～かなと気を回しました
。。。inputboxのパラメータを変えてみます。
少しお待ちくださいね。
m(__)m

（隠居じーさん） 2018/10/07(日) 13:15

 お待たせいたしました。　＾＾
下記コードに差し換えてください。

 Option Explicit
Sub 品名別集計()
   Dim i As Variant
   Dim ans As Long
   Dim r As Range
   i = Application.InputBox(Title:="数量算出【Ａ列】", _
                            Prompt:="検索文字列を入力しなさい。" & vbCrLf & _
                            "ある文字を含む項目の合計を算出します。" & _
                            vbCrLf & "集計範囲はA67～A4500" & vbCrLf & _
                            "※注意" & vbCrLf & "上記範囲以外は別集計", _
                            Default:="製品（例として）", _
                            Left:=50, _
                            Top:=150, _
                            Type:=2)
    If VarType(i) = vbBoolean Then
          'If i = "" Or i = False Then
          '   If i = "" Then
          Exit Sub
    End If
    'MsgBox Format(WorksheetFunction.SumIf(Range("A67:A4500"), "*" & i & "*", Range("F67:F4500")), "#,##0")
    ans = Format(WorksheetFunction.SumIf(Range("A1:A4500"), "*" & i & "*", Range("F1:F4500")), "#,##0")
    On Error Resume Next
    Set r = Application.InputBox(Title:="数量算出結果【Ｆ列】＝　" & ans, _
                            Prompt:="出力先を入力して下さい。" & _
                            vbCrLf & "集計範囲はA67～A4500" & vbCrLf & _
                            "※注意" & vbCrLf & "上記範囲以外は別集計", _
                            Default:="H2", _
                            Left:=50, _
                            Top:=150, _
                            Type:=8)
    On Error GoTo 0
    If r Is Nothing Then
        Exit Sub
    End If
    r = ans
    Application.Goto r
End Sub
（隠居じーさん） 2018/10/07(日) 13:38

（隠居じーさん）さん
ありがとうございました。
無事セル記入できました。
（山口） 2018/10/07(日) 16:03

コメント返信：

[ 一覧(最新更新順) ]

[[20181007031515]] 『答えを任意セルに記入』（山口） ページの最後に飛ぶ

[[20181007031515]]　『答えを任意セルに記入』（山口）　ページの最後に飛ぶ