VBAでカウントアップ

Question

日々売れたものを随時数を入力し、カウントアップしていきます。
入力場所はA1セルで、
例えば今日が10月19日で、"製品C"とA1セルに入力するとE20セルが10⇒11になります。
カウントアップ後、A1セルはクリアされます。
もし、入力した名前がない場合は、”登録がありません。追加しますか？"と表示がでたあと、OKをクリックするとA行の末(今回はＫ1セル)に追加され、Ｋ20セルが0⇒1になります。OKでない場合は、A1セルをクリア後、マクロ終了。

上記のようなことは可能でしょうか？よろしくお願いします。

tom04 · Accepted Answer

No.1です。

＞構文の内容を補足で追加して・・・
コードの説明というコトでしょうか？

やっていることはINDEX関数のような感じです。
日付で行番号、商品名で列番号を取得し、そのセルに「1」をプラスする！といった感じのコードです。

前回のコードに少しだけコメントを入れておきます。

Private Sub Worksheet_Change(ByVal Target As Range)
'//変数の宣言//
Dim lastCol As Long, myRng As Range
Dim c As Range, r As Range

'//変化セルの・・・//
With Target
'//セル番地が「A1」の場合//
If .Address = "$A$1" And .Count = 1 Then
'//空白以外の場合//
If .Value <> "" Then
'//1行目最終列（入力済みの商品名の最終列番号）を取得//
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
'//myRngに商品入力済みの1行目セル範囲を格納//
Set myRng = Range(Cells(1, "C"), Cells(1, lastCol))
'//日付セル列B列の中の「今日」のシリアル値のセルを取得（←行番号取得のため）★//
Set c = Range("B:B").Find(what:=DateValue(Date), LookIn:=xlFormulas, lookat:=xlWhole)
If c Is Nothing Then '//←念のため//
MsgBox "今日の日付がありません。"
Exit Sub
End If
'//myRngの範囲内でA1セルに入力した商品名のセルを取得（←列番号取得のため）//
Set r = myRng.Find(what:=.Value, LookIn:=xlValues, lookat:=xlWhole)
'//A1セルの商品名がmyRngにない場合は・・・//
If r Is Nothing Then
If MsgBox("登録がありません。" & vbCrLf & "追加しますか？", vbYesNo) = vbYes Then
'//1行目最終列の一つ右となりにA1セルの値を代入//
Cells(1, lastCol + 1) = .Value
'//上記セルに「1」を代入//
Cells(c.Row, lastCol + 1) = 1
End If
Else
'//↓myRngにA1の商品名が存在する場合、そのセルの・・・//
With Cells(c.Row, r.Column)
'//値=値+1とする//
.Value = .Value + 1
End With
End If
'//A1セルを消去//
.ClearContents
'//A1セルを選択//
.Select
End If
End If
End With
End Sub

※　気を付けなければならない点としては
VBAで日付セル（シリアル値）を検索する場合、単純に「Find」では検索できないことがほとんどです。
上記コード内の「★」の下の行のような感じだとお使いのバージョンであれば
表示形式がどのようになっていても取得できます。m(_ _)m

tom04 · Answer

こんばんは！

増えていくのは「1」ずつでよいのですよね？

一例です。シートモジュールにしてください。

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lastCol As Long, myRng As Range
    Dim c As Range, r As Range
    With Target
        If .Address = "$A$1" And .Count = 1 Then
            If .Value <> "" Then
                lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
                Set myRng = Range(Cells(1, "C"), Cells(1, lastCol))
                Set c = Range("B:B").Find(what:=DateValue(Date), LookIn:=xlFormulas, lookat:=xlWhole)
                If c Is Nothing Then    '//←念のため//
                    MsgBox "今日の日付がありません。"
                    Exit Sub
                End If
                Set r = myRng.Find(what:=.Value, LookIn:=xlValues, lookat:=xlWhole)
                    If r Is Nothing Then
                        If MsgBox("登録がありません。" & vbCrLf & "追加しますか？", vbYesNo) = vbYes Then
                            Cells(1, lastCol + 1) = .Value
                            Cells(c.Row, lastCol + 1) = 1
                        End If
                    Else
                        With Cells(c.Row, r.Column)
                            .Value = .Value + 1
                        End With
                    End If
                    .ClearContents
                    .Select
            End If
        End If
    End With
End Sub

こんな感じではどうでしょうか？m(_ _)m

GooUserラック · Answer

回答ではありません

「製品〇」と入力するのは結構面倒ではありませんか？
個人的には１行目の項目の部分をダブルクリックまたは右クリックしてカウントアップの方が簡単なような気がするのですがいかがでしょうか？

VBAでカウントアップ

No.1です。

こんばんは！

回答ではありません

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング