エクセルVBAで商品の単価変更を行う方法

このQ&Aのポイント
  • エクセルVBAを使用して商品の単価を変更する方法について教えてください。
  • エクセルに作成した表には商品名、商品区分、単価のデータがあります。ユーザーフォームを表示し、商品区分と単価上昇率を入力し、ボタンをクリックすると、対象商品の単価を変更する処理を行いたいです。
  • 処理の流れは以下の通りです。 1. ユーザーフォームを表示する 2. 商品区分と単価上昇率を入力する 3. ボタンをクリックすると、対象商品の単価を変更する 4. 変更した明細の件数をメッセージボックスで表示する
回答を見る
  • ベストアンサー

エクセルVBAについて、ご教授お願いします。

表を作成しました。      1 商品名 商品区分  単価     2 ミカン   1        \50  3 リンゴ  2         \80 4 モモ   8        \100  Msgboxに商品区分と単価上昇率を入力し、コマンドボタンの単価変更をクリックすると、 エクセル(商品区分、単価)のデータを読み下記の条件で実行します。 ------------------------------------------------------------------------------------ A.単位上昇率に関してエラーチェックを行います。 'B.エラーが見つかった場合にのみ、対象商品区分の単位上昇率を元にワークシート上の明細を更新する 'C.処理条件をメッセージボックスにて表示する。 ------------------------------------------------------------------------------------- どうしても思うような処理を作成できず悩んでいます。 良い方法をご存じの方がいらっしゃいましたら、どうかお教えください。 Option Explicit Sub ユーザーフォーム表示() 'P79 単価変更画面.Show End Sub '単価変更版 '------------------------------------------- 'A.単位上昇率に関してエラーチェックを行います。 'B.エラーが見つかった場合にのみ、対象商品区分の単位上昇率を元にワークシート上の明細を更新する 'C.処理条件をメッセージボックスにて表示する。 '---------------------- Private Sub 終了_click() End End Sub Private Sub 商品区分_change() End Sub Private Sub 単価上昇率_change() End Sub Private Sub 単価変更_Click() Dim i As Long Dim cut As Integer Dim 単価上昇率 As String Dim 商品区分 As String If IsNumeric(単価上昇率) = False Then MsgBox ("数値を入力して下さい。") 単価変更画面.単価上昇率.SetFocus i = Cells(i, 4) End If i = 3 cut = 0 Do While Cells(i, 4) <> "" If Cells(i, 4) = 単価変更画面.商品区分.Text Then   Cells(i, 6) = Cells(i, 6) * (1 + 単価変更画面.単価上昇率.Text / 100) cut = cut + 1 End If    i = i + 1    Loop If cut = 0 Then MsgBox ("該当する商品は存在 しませんでした。 ") 単価変更画面.商品区分.SetFocus Else MsgBox (cut & "件の明細を変更しました。") End If End Sub

質問者が選んだベストアンサー

  • ベストアンサー
  • seastar3
  • ベストアンサー率69% (99/142)
回答No.1

要するに、ある商品区分の行だけ単価上昇率を上乗せした単価をF列に書き出したいのですね。 単価上昇率と単位上昇率が混在しているので、趣旨があいまいになっています。 とりあえず、影さんのコードをそれらしく手直ししてみると、以下のようになります。 これを参考にデバッグしてみましょう。 ' 単価上昇率テキストボックスが書き換わった際にチェックするようにする。もっと細かいチェックも個々に書き込む。 Private Sub 単価上昇率_change() If Not IsNumeric(Value(単価変更画面.単価上昇率.Text)) Then MsgBox ("数値を入力して下さい。") 単価変更画面.単価上昇率.SetFocus End If End Sub ' 単価上昇率を数値化してから計算式に入れる。 Private Sub 単価変更_Click() Dim i As Long Dim cut As Integer Dim 単価上昇率 As String Dim 商品区分 As String i = 3 cut = 0 Do While Cells(i, 4) <> "" If Cells(i, 4) = value(単価変更画面.商品区分.Text) Then Cells(i, 6) = Cells(i, 4) * (1 + value(単価変更画面.単価上昇率.Text) / 100) cut = cut + 1 End If i = i + 1 Loop If cut = 0 Then MsgBox ("該当する商品は存在 しませんでした。 ") 単価変更画面.商品区分.SetFocus Else MsgBox (cut & "件の明細を変更しました。") End If End Sub

kage1642
質問者

お礼

回答ありがとうございました。とてもわかりやすかったです。 正常に起動しました。

その他の回答 (1)

  • CC_T
  • ベストアンサー率47% (1038/2201)
回答No.2

要望の回答になってませんが、すいません。 とりあえず、Private Sub 単価変更_Click() で、i = Cells(i, 4) がありますが、 ここでiが初見、ということでiの初期値ゼロでCells(0, 4)指定になってエラーになるような・・・。 あとは、商品区分や単価上昇率は表では数値のようですがsub中では文字型のStringで宣言ているのに、 商品区分をわわざIsNumericで数値かチェックかけたり、掛け算で使ったりしてません?とか 単価変更画面.単価上昇率.Text など文字型なのに掛け算に使ってるとか(Value、では?)、 とまぁそのへんが原因で何を入れても該当なしで終了メッセージ出すか、数値が変わらないかってところじゃないですか? そういうのはデバッグのウォッチ式で監視したり、デバッグ用に所どころにmsgboxで表示させてみたりして、型が適切かチェックをしていけばつぶせるかと。

kage1642
質問者

お礼

ありがとうございます。大変参考になりました。 またデバックについて教えて頂きありがとうございます。 試してみます。

関連するQ&A

  • Excel VBAで検索(Win2000 Excel2000)

    現在、下記のようなコードを書いています。データテーブルの縦と横の検索値を探してその列数と行数を返したいのですが、下記の Sub検索1 と Sub検索2 を1つのSubで実行させるにはどうしたらよいのでしょうか?よろしくお願い致します。 ----------------------------------------- Sub 検索1() Worksheets("Data").Activate Dim x As Integer For x = 3 To 22 If Cells(2, x).Value >= 12 Then MsgBox x Exit Sub End If Next MsgBox "見つかりません" End Sub --------------------------------------------- Sub 検索2() Worksheets("Data").Activate Dim i As Integer For i = 4 To 42 If Cells(i, 2).Value = "A" Then MsgBox i Exit Sub End If Next MsgBox "見つかりません" End Sub

  • EXCEL VBA2010 MsgBox

    Sub 重複() Dim i As Long, j As Long For i = 6 To 500 For j = 3 To 3 If WorksheetFunction.CountIf(Range("C6:C500"), Cells(i, j)) > 1 Then Cells(i, j).Interior.ColorIndex = 6 End If Next j Next i End Sub このVBAに重複が何件ありますよというメッセージを出したいです。 MsgBoxの入れ方を教えてください。

  • VBAで教えてください。

    データがないときはExitSubしたいのですが、何処に記述すれば良いでしょうか? Sub 削除() Dim i As Long If MsgBox("データを削除します。よろしいですか?", vbYesNo) = vbYes Then Sheets("リスト").Select i = 5 Do Until i = 200 If Cells(i, 5).Value = Sheets("マスタ登録").Range("D5") Then Cells(i, 1).EntireRow.Delete End If i = i + 1 Loop Else Exit Sub End If End Sub

  • Excel VBA 列の最後の値を代入

    たびたびすみません。 指定したセルの、最終列の値を、任意のセルに入れたいのですが、 オブジェクトが必要です、というエラーがでます。 Sub 単価代入() Dim i As Integer Application.ScreenUpdating = False For i = Range("IV2").End(xlToLeft).Column To 1 Step -1 If InStr(Cells(2, i).Value, "単価") > 0 Then Cells(3, i).Value = Cells(3, i).End(xlToRight).Column.Value End If Next i Application.ScreenUpdating = True End Sub Cells(3, i).Value = のあとの指定方法がまずいのかと思いますが。。 どうぞ宜しくお願い致します。

  • ユーザーホームでの検索について(エクセル)

    コンボボックスで選択した文字とシートの表にある文字が一致か不一致かでMsgBoxに表示させるコードです。 一番上の行を選択しコマンド1ボタンを押すと正常に表示されるが2行目以降を選択すると一致不一致に関わらずすべて注意文が表示されます。  現在シート2,3ともとも10行目までデータがあります。今後データは下の行へと増える予定です。  コマンドボタン1のコード Private Sub cmd検索_Click() Dim i As Long For i = 4 To Sheets("sheet3").Cells(Rows.Count, 3).End(xlUp).Row If Sheets("sheet3").Cells(i, 3) = ComboBox1 Then MsgBox "商品 『 " & Sheets("sheet3").Cells(i, 3).Value & " 』 の在庫数は 『 " & Sheets("sheet3").Cells(i, 9).Value & " 』 です。" Exit Sub Else MsgBox "その商品は登録されていません。", vbExclamation Exit Sub End If Next i End Sub コンボボックスのコード Private Sub UserForm_Initialize() Dim i As Long With Worksheets("sheet2") For i = 4 To .Cells(Rows.Count, 3).End(xlUp).Row ComboBox1.AddItem .Cells(i, 3).Value Next i End With End Sub どこが間違っているのか教えていただけないでしょうか。 よろしくお願いいたします。

  • エクセルVBAでDictionaryオブジェクトについて

    エクセル2000です。 教えてください。 http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_dictionary.html というサイトで  「myDic.Add Cells(i, 1).Value, Cells(i, 2).Value は   myDic(Cells(i, 1).Value) = Cells(i, 2).Value と書くこともできます。 」 という記述を見つけました。 試してみたところ Sub test01() Dim myDic As Object Dim myAr() Set myDic = CreateObject("Scripting.Dictionary") For i = 2 To 7 If Not myDic.exists(Cells(i, 1).Value) Then myDic.Add Cells(i, 1).Value, Cells(i, 2).Value End If Next i myAr() = myDic.Keys MsgBox Join(myAr()) End Sub Sub test02() Dim myDic As Object Dim myAr() Set myDic = CreateObject("Scripting.Dictionary") For i = 2 To 7 myDic(Cells(i, 1).Value) = Cells(i, 2).Value Next i myAr() = myDic.Keys MsgBox Join(myAr()) End Sub 上記2つのマクロは、Keyに関してはまったく同じ働きをするようです。 ところがItemに関しては、Keyが重複した場合、あとから出てきた方に上書きされるようです。 これはtest01では、Keyの重複を排除しているためItemは最初に出たものが残る、test02は重複の場合、無条件でKeyが上書きされ(ても値は変化しないけど)、したがってItemも上書きされるという理解でよろしいのでしょうか? ならば、Itemを気にしない場合、わざわざ If Not myDic.exists(Cells(i, 1).Value) Then myDic.Add Cells(i, 1).Value, Cells(i, 2).Value End If と、3行も費やして重複のチェックをしなくとも myDic(Cells(i, 1).Value) = Cells(i, 2).Value のわずか一行で済むということですよね?

  • ユーザーフォームが閉じたいのですが

    皆様こんにちは。 ExcelVBAを使ってユーザーフォームを作っています(初心者)。 どうしてもわからないので教えてください。 ちなみに、以下のように組んでいます。 Private Sub 商品区分txt_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean) If IsNumeric(商品区分txt) = False Then   MsgBox "商品区分は数値を入力してください", , "商品区分エラー"   Cancel = True   Exit Sub End If If 商品区分txt < 1 Or 商品区分txt > 100 Then   MsgBox "商品区分は1~100までの値で入力してください", , "商品区分エラー"   Cancel = True   Exit Sub End If End Sub 説明させていただくと、「単価変更」というボタンを配置しています。 そのボタンをクリックするとユーザーフォームが立ち上がります。 商品区分と単価変更率を入力するテキストボックスがあります。 両方を入力後「単価変更実行」というボタンを押すようになっています。 すると指定した商品区分の商品の単価が変更されるようになります。 ちなみに、「終了」ボタンもあります。 商品区分は1~100まであり、その範囲外の場合と数値以外が入力された場合はエラーメッセージがでるようになっています。 たとえば、商品区分に200を入力するとメッセージが出て次のコントロールにいけないようになっています。 そこで200を消します。そして、「とりあえず終了したい」となり、終了ボタンを押してもエラーメッセージが出てしまいます。 このメッセージは出したくありません。 出さないようにするにはどうしたらいいでしょうか? BeforeUpdateじゃなく何か別のイベントを選ぶといいのでしょうか? ちなみに、終了ボタンはUnload Meとしてあるので通常は閉じることは可能です。 長文ですみません。よろしくお願いします。

  • エクセルのマクロについて

    Sub ア_Click() Dim i As Long With ActiveSheet For i = 5 To .Cells(Rows.count, "C").End(xlUp).Row If InStr(.Cells(i, "C"), "ア") = 0 Then If InStr(.Cells(i, "D"), "ア(半角)") = 0 and .Cells(i,"D")<>"" Then MsgBox i & "行目" Cells(i, 2).Offset(0, -1).Value = "★" End If End If Next i End With End Sub このエクセルマクロはC列に「ア」があって、D列に「ア(半角)」の文字がない場合はメッセージというマクロなのですが、このマクロをア~ンまで同じ作業をしたいのですが、ひとまとめにマクロを組む事はできるのでしょうか?できる場合どのようにすれば良いでしょうか? 下記のようにして見たのですができませんでした。 Sub ア_Click() Dim i As Long With ActiveSheet For i = 5 To .Cells(Rows.count, "C").End(xlUp).Row If InStr(.Cells(i, "C"), "[ア-ン]") = 0 Then If InStr(.Cells(i, "D"), "[ア-ン](半角)") = 0 and .Cells(i,"D")<>"" Then MsgBox i & "行目" Cells(i, 2).Offset(0, -1).Value = "★" End If End If Next i End With End Sub

  • VBAコードでメッセージがうまく返せません

    独学でVBAを始めて1ヶ月の初心者です。 下記のコードについて質問です。 シート"strage2"のA1からA15のデータをシート"strage1"と比較し、違ったら更新します。 更新したデータだけを、まとめてメッセージボックスで返したいのです。 しかし、返してくるのは一番最後に処理した値だけなのです。 何が間違いでしょうか? ご指南よろしくお願いいたします。 --------------------------- Sub 何を書き換えたかMsgBox() Dim i As Integer Dim myMsg As String i = 1 For i = i To 15 If Sheets("strage1").Cells(i, 1) <> Sheets("strage2").Cells(i, 1) Then myMsg = Sheets("strage1").Cells(i, 1).Value & "から" & Sheets("strage2").Cells(i, 1) & "に変更しました" & vbCrLf Sheets("strage1").Cells(i, 1).Value = Sheets("strage2").Cells(i, 1) Else End If Next i MsgBox myMsg End Sub -------------------------------------- 以上です。よろしくお願いします。

  • EXCEL VBA 

    Excel VBAで アンケート集計をしたいと思い、プログラムを作ったのですが、J列までは入力がうまくいくのですが、K列にデータを入れて次の行にデータを入れると もともと存在していたKれつのデータが消えてしまします。 どう修正すれば ちゃんとデータが残ってくれるのでしょうか?  誰か教えてください Option Explicit Private Sub UserForm_Initialize() Dim チェックボックス As Control With cboBlood .AddItem "A型" .AddItem "B型" .AddItem "O型" .AddItem "AB型" End With cboBlood.ListIndex = -1 txtNo.Value = WorksheetFunction.Max( _ [Database].Resize(, 1)) + 1 txtNo.Enabled = False txtName.Text = "" optMale.Value = True txtAge.Value = 0 For Each チェックボックス In fraOS.Controls チェックボックス.Value = False Next txtName.SetFocus End Sub Private Sub cmdEntry_Click() Dim 行 As Long Dim 確認 As Integer 確認 = MsgBox("データを登録します。" _ & "よろしいですか?", vbYesNo) If 確認 <> vbYes Then Exit Sub 行 = [Database].Rows.Count + 1 [Database].Cells(行 - 1, 1).EntireRow.Insert [Database].Offset(行 - 1).Resize(1).Copy _ [Database].Cells(行 - 1, 1) [Database].Offset(行 - 1).Resize(1).ClearContents [Database].Cells(行, 1) = txtNo.Value [Database].Cells(行, 2) = txtName.Text If optMale.Value = True Then [Database].Cells(行, 3) = "男性" Else [Database].Cells(行, 3) = "女性" End If [Database].Cells(行, 4) = cboBlood.Text [Database].Cells(行, 5) = txtAge.Value If chkWin.Value = True Then _ [Database].Cells(行, 6) = "○" If chkMac.Value = True Then _ [Database].Cells(行, 7) = "○" If chkLinux.Value = True Then _ [Database].Cells(行, 8) = "○" If chkOther.Value = True Then _ [Database].Cells(行, 9) = "○" If chkOther.Value = True Then _ [Database].Cells(行, 10) = "○" Unload frmNew End Sub Private Sub cmdCancel_Click() Unload frmNew End Sub

専門家に質問してみよう