メッセージボックスについて

このQ&Aのポイント
  • 上司に言われた締め切りがあと4日になってしまいました。在庫管理で在庫残高シートに次のプログラムをはってみました。
  • アクティブになってる入力シートに入力したときに、アクティブシートにメッセージボックスを出したいのですが、どうすればよいでしょう。
  • 入力シートの一部のセルが在庫残高シートのセルに参照されるため、貼り付ける方法ではないと考えました。
回答を見る
  • ベストアンサー

メッセージボックスについて。

上司に言われた締め切りがあと4日になってしまいました。 在庫管理で在庫残高シートに次のプログラムをはってみました。 Private Sub Worksheet_Change(ByVal Target As range) Dim clm As Integer '変化したセルの列 Dim row As Integer '変化したセルの行 Dim counter As Integer '不足数 clm = Target.Column row = Target.row If Worksheets("在庫残高").Cells(row, clm) < Worksheets("在庫限界入力").Cells(row, clm) And Worksheets("在庫残高").Cells(row, clm) > 0 Then counter = Worksheets("在庫限界入力").Cells(row, clm) - Worksheets("在庫残高").Cells(row, clm) MsgBox counter & "本在庫不足", vbOKOnly, "注意" Else If Worksheets("在庫残高").Cells(row, clm) < 0 Then MsgBox "在庫がありません", vbOKOnly, "警告" End If End If End Sub アクティブになってる入力シートに入力したときに、アクティブシートにメッセージボックスを出したいのですが、どうすればよいでしょう。複数の入力シートに これを全て貼り付けることも考えましたが、入力シートの何個かのセルが、 在庫残高シートの一つのセルに参照されるようになっているので、そうしないほうが、 いいんじゃないかなとおもいました。 よろしくお願いします。

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

  • ベストアンサー
  • qwedesu
  • ベストアンサー率31% (6/19)
回答No.1

ブックのイベントモジュールで シートがアクティブになった時と変更の時で制御すれば、いいですよ。 具体的例として.... Option Explicit Dim chg As Boolean Private Sub Workbook_SheetActivate(ByVal Sh As Object) chg = False End Sub Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) If Not chg Then MsgBox CStr(Target.Value) chg = True End If End Sub

majimekun
質問者

お礼

ありがとうございました。 とりあえず、自分のできる範囲で作ってしまいました。 おかしくなったときに、自分でやったものを治すことはできますから。 でも、今度いろんなものを作るときに、皆さんの意見を参考に していきたいと思います。 本当に感謝しています。

関連するQ&A

  • エクセルで、こうやっても反応なしです。

    よろしくお願いします。以下のように組んで見ました。 Private Sub Worksheet_Change(ByVal Target As range) Dim clm As Integer Dim row As Integer clm = Target.Column row = Target.row If Worksheets("発注指示").Cells(row, clm) = "不足" Then MsgBox "在庫不足", vbOKOnly, "注意" End If End Sub どうして動かないのでしょう。 本当にわからないので、教えてください。 これで一日つぶれました。

  • エクセル:シートを切り替えずに別シート上の操作をする

    タイトルが正しいかどうか疑問ですが。 シート[Sheet1]にて値を入力したアドレス(の行番号と列番号)を取得し、 その周囲のセルの罫線の色を赤(3)から灰色(15)に置換するコードを作っています。 Sheet1のコードには、 Private Sub Worksheet_Change(ByVal Target As Range)  AAA Target End Sub とだけ書き、入力があったらプロシージャAAAへTargetを持って飛びます。 Sub AAA(ByVal Target As Range)  Dim M_Row As Integer  Dim M_Clm As Integer  Dim Y As Range  M_Row = Target.Row  M_Clm = Target.Column  For Each Y In Worksheets("Sheet1").Range(Cells(M_Row - 2, M_Clm), Cells(M_Row + 1, M_Clm + 5))   With Y    If .Borders(xlEdgeTop).ColorIndex = 3 Then .Borders(xlEdgeTop).ColorIndex = 15    If .Borders(xlEdgeLeft).ColorIndex = 3 Then .Borders(xlEdgeLeft).ColorIndex = 15    If .Borders(xlEdgeBottom).ColorIndex = 3 Then .Borders(xlEdgeBottom).ColorIndex = 15   End With  Next End Sub ここまでは正常に動きます。 この後に、アクティブでないシート[Sheet2]の同じセル範囲にある罫線の色も同じように置換したいので、 上記コードに続けて、以下のように書きました。 Sub AAA(ByVal Target As Range)  Dim M_Row As Integer  Dim M_Clm As Integer  Dim Y As Range  M_Row = Target.Row  M_Clm = Target.Column  For Each Y In Worksheets("Sheet1").Range(Cells(M_Row - 2, M_Clm), Cells(M_Row + 1, M_Clm + 5))   With Y    If .Borders(xlEdgeTop).ColorIndex = 3 Then .Borders(xlEdgeTop).ColorIndex = 15    If .Borders(xlEdgeLeft).ColorIndex = 3 Then .Borders(xlEdgeLeft).ColorIndex = 15    If .Borders(xlEdgeBottom).ColorIndex = 3 Then .Borders(xlEdgeBottom).ColorIndex = 15   End With  Next  For Each Y In Worksheets("Sheet2").Range(Cells(M_Row - 2, M_Clm), Cells(M_Row + 1, M_Clm + 5))   With Y    If .Borders(xlEdgeTop).ColorIndex = 3 Then .Borders(xlEdgeTop).ColorIndex = 15    If .Borders(xlEdgeLeft).ColorIndex = 3 Then .Borders(xlEdgeLeft).ColorIndex = 15    If .Borders(xlEdgeBottom).ColorIndex = 3 Then .Borders(xlEdgeBottom).ColorIndex = 15   End With  Next End Sub これだと、  For Each Y In Worksheets("Sheet2").Range(Cells(M_Row - 2, M_Clm), Cells(M_Row + 1, M_Clm + 5)) の部分で失敗します。 この1行前に、  Sheets("Sheet2").Select と入れてやると正常に動作するのですが、 シートを切り替えずにやりたいと思っています。 可能でしょうか? 以下のように、 実行後にSheet1に戻し、 それらを Application.ScreenUpdating = False Application.ScreenUpdating = True で挟むことで、見た目はシートを切り替えずに実行できるのですが、 実際にこのコードを組み込んでいるシートはシート上にあるデータが多いためか(600行×100列程度)、 全く同じコードを実行しても一瞬画面がチラついてしまいます。 (新規Bookで同じコードを組み込んで、何行かに罫線を引いただけのシートだと全くチラつかなかったので、 シート上のデータが多いせいじゃないかと思いました) Sub AAA(ByVal Target As Range)  Dim M_Row As Integer  Dim M_Clm As Integer  Dim Y As Range  M_Row = Target.Row  M_Clm = Target.Column  For Each Y In Worksheets("Sheet1").Range(Cells(M_Row - 2, M_Clm), Cells(M_Row + 1, M_Clm + 5))   With Y    If .Borders(xlEdgeTop).ColorIndex = 3 Then .Borders(xlEdgeTop).ColorIndex = 15    If .Borders(xlEdgeLeft).ColorIndex = 3 Then .Borders(xlEdgeLeft).ColorIndex = 15    If .Borders(xlEdgeBottom).ColorIndex = 3 Then .Borders(xlEdgeBottom).ColorIndex = 15   End With  Next  Application.ScreenUpdating = False  Sheets("Sheet2").Select  For Each Y In Worksheets("Sheet2").Range(Cells(M_Row - 2, M_Clm), Cells(M_Row + 1, M_Clm + 5))   With Y    If .Borders(xlEdgeTop).ColorIndex = 3 Then .Borders(xlEdgeTop).ColorIndex = 15    If .Borders(xlEdgeLeft).ColorIndex = 3 Then .Borders(xlEdgeLeft).ColorIndex = 15    If .Borders(xlEdgeBottom).ColorIndex = 3 Then .Borders(xlEdgeBottom).ColorIndex = 15   End With  Next  Sheets("Sheet1").Select  Application.ScreenUpdating = True End Sub よろしくお願いします。

  • エクセルVBAで在庫管理。初心者です。

    こんにちは。よろしくお願いします。 エクセルで出荷入力画面シートに数字を入力。もし、発注しなくてはならない 在庫数設定より(在庫限界入力シート)、その商品の総合計(在庫残高シート)が 少なくなったら、メッセージボックスに警告を表示したいのです。 先日、親切な方々のアドバイスで、以下のように組んで見ましたが、 入力シートにはたくさんの商品があり、どのセルに入れても全部同じメッセージ ボックスがでてしまいます。これができないと、お茶組のままです。 がんばって作ってきたエクセルが、期限に間に合いません。助けてください。 Private Sub Worksheet_Calculate() dim counter as integer If Worksheets("在庫残高").Range("C6") < Worksheets("在庫限界入 力").Range("C6") Then counter=Worksheets("在庫限界入力").Range("C6")-Worksheets("在庫 残高").Range("C6") MsgBox counter& "本在庫不足", vbOKOnly, "警告" End If End Sub 一行目のworksheetをobjectにしてもだめでした。また()のなかに入力する 全てのセルの範囲を指定してもだめでした。 どうすればいいのでしょう。

  • 配列表示と間引き

    配列の間引きをを教えて下さい。 下記文を書きました Sub 配列() Dim u As Integer '左 Dim v As Integer '中 Dim w As Integer '右 Dim x As Integer '左 Dim y As Integer '中 Dim z As Integer '右 Dim row As Integer '行カウンタ Dim col As Integer '列カウンタ Dim intSheet As Integer 'シートカウンタ Dim blnNextPage As Boolean '次シートフラグ '初期値セット u = 1 v = 2 w = 3 x = 4 y = 5 z = 5 row = 0 col = 1 intSheet = 1 Do While (1) 'zカウント z = z + 1 If z > 20 Then 'zが20以上ならy+1 y = y + 1 If y > 19 Then 'yが20以上ならx+1 x = x + 1 If x > 18 Then 'xが20以上ならy+1 w = w + 1 If w > 17 Then 'wが20以上ならx+1 v = v + 1 If v > 16 Then 'wが20以上ならx+1 u = u + 1 '終了条件 If (x = 19 And y = 19 And z = 20) Then Exit Do 'v初期化 = x+1 v = u + 1 End If 'w初期化 = y+1 w = v + 1 End If 'x初期化 = x+1 x = w + 1 End If 'y初期化 = y+1 y = x + 1 End If 'z初期化 = y+1 z = y + 1 End If If z > 20 Then Exit Sub '行カウント row = row + 1 If row > 1000 Then '1000で次の列か次のページへ If blnNextPage Then '行・列カウンタ初期化 col = 1 row = 1 '次のシートへ intSheet = intSheet + 1 '次のシートが無い場合は追加 If intSheet > Worksheets.Count Then Sheets.Add After:=Worksheets(Worksheets.Count) End If 'シートをアクティブに Worksheets(intSheet).Select 'フラグ消去 blnNextPage = False Else '次の列へ col = col + 6 row = 1 'blnNextPage = True End If End If If col = 6 * 3 + 1 Then blnNextPage = True End If 'データ表示 Worksheets(intSheet).Range(Chr(64 + col) & row).Cells = u Worksheets(intSheet).Range(Chr(64 + col + 1) & row).Cells = v Worksheets(intSheet).Range(Chr(64 + col + 2) & row).Cells = w Worksheets(intSheet).Range(Chr(64 + col + 3) & row).Cells = x Worksheets(intSheet).Range(Chr(64 + col + 4) & row).Cells = y Worksheets(intSheet).Range(Chr(64 + col + 5) & row).Cells = z Loop End Sub 上記文で表示をしますが、 6列目までの間に3列の連数字の時には表示を行わず、次に移る様にしたいのですが、どうすれば良いでしょうか? 1,2,5,6,10,12はOKです 1,2,3,5,6,10又は1,3,4,5,10,11等3連の数字は表示を行わない。

  • 完全一致したら複数のセルを順に代入するマクロは?

    エクセルのSheet1のA列にある文字列と、Sheet2にあるA列にある文字列と完全一致したら、前者のセルの右右右隣セル(一致したセルから数えて4番目のセル)から3番目までのセルに、後者のセルの右隣セル(一致したセルから数えて2番目のセル)から3番目までの文字列を順に代入するマクロをお教えください。つまり代入開始セルをSheet1のD列にしたいのです。(実は任意の列からにしたのですが…)。単純にvlookup関数を使えばいいのですが、VBAで行いたいのです。 一致したセルの右隣のセルから順に代入するマクロは以下で解決済みです。以下のマクロを編集して実行したいのですが、どこをいじったらよいかわかりません。 なお、代入したいセルを右の任意のセルまで引き延ばしたい場合、以下のコード任意Loop Until Coln1 = 4の右辺の数字を変更すればよいことまではわかっています。どうぞ、よろしくお願い申し上げます。 ---------------- Sub 試験() Dim Row1 As Integer Dim Coln1 As Integer Dim Row2 As Integer Dim Coln2 As Integer Set WS1 = Worksheets("Sheet1") Set WS2 = Worksheets("Sheet2") Coln1 = 1 Coln2 = 1 For Row1 = 1 To WS1.Cells(Rows.Count, 1).End(xlUp).Row For Row2 = 1 To WS2.Cells(Rows.Count, 1).End(xlUp).Row If WS2.Cells(Row2, 1) = WS1.Cells(Row1, 1) Then Do Coln1 = Coln1 + 1 Coln2 = Coln2 + 1 WS1.Cells(Row1, Coln1) = WS2.Cells(Row2, Coln2) Loop Until Coln1 = 4 Coln1 = 1 Coln2 = 1 End If Next Row2 Next Row1 End Sub

  • 初心者です。お願いします!!

    はじめまして。真紀といいます。 ここ1月くらい悩みましたが、まったく答えがわからず、答えの探し方もわかりません。 どうか、このプログラムだけ、完成させてください.お願いします;; シート1の(i,1)に写真を貼り付けると、サイズを補正して張り付き、 シート2の中から、シート1と同じ名前が付いているものを(i,1)から探して、見つけたらその2行目に書いてある数値を任意のセルに入力する。 このプログラムをいろんな人のホームページから探して書いたのですが、どうしても写真と同じ『名前』が分かりません。 教えてください><。。。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim selectRowNo As Long Dim afile As Variant Dim i As Long Select Case Target.Column Case 1 selectRowNo = Target.Row Worksheets("sheet1").Activate Worksheets("sheet1").Cells(selectRowNo, 1).Select afile = Application.GetOpenFilename("bmpファイル (*.bmp), *.bmp", , , , True) If IsArray(afile) Then ActiveSheet.Pictures.Insert(afile).Select Selection.ShapeRange.LockAspectRatio = msoTrue Selection.ShapeRange.Height = 235.5 Selection.ShapeRange.Width = 385.5 End If For i = 1 To 100 If Worksheets("sheet2").Cells(i, 1) = "" Then Else If Left(Worksheets("sheet2").Cells(i,1), Len("afile-THD")) = "afile-THD" Then Worksheets("sheet1").Cells(Target.Row + 7, 11)           = Worksheets("sheet2).Cells(i, 2) Exit For End If End If Next 以上ですが、bmpは気にしないでください。 afile-THDの部分がいけないと思うのですが、拡張子が付いてるなまえだからいけないのかな?;; よろしくお願いします><

  • VBAのファイル参照について

    セルの変更時、列によって行の内容を変更するプログラムを組んだのですが、 エラーが起きてうまくいきません。 使用しているExcelは2007です。 ファイルを参照するあたりが全然わかってないのでそのあたりがあやしいです。 実行時エラー '91': オブジェクト変数または With ブロック変数が設定されていません。 → hoge = book1.Worksheets(customer).Range("A34:D" & endrow) '係数表をコピー ↓デバッグ押すと 実行時エラー '-2147417848 (80010108)': 'Value' メソッドは失敗しました: 'Range'オブジェクト → Call all_feeCulc_change2(target.Parent.Name, target.row) 番号をメモし忘れました。91かこれが表示されます。どちらが出るかわかりません。 'Range' メソッドは失敗しました:'_Worksheet' オブジェクト →endrow = book1.Worksheets(customer).Cells(Rows.Count, 1).End(xlUp).row '最終行番号を取得 何回かリトライして開いたり閉じたりを繰り返したら↓のようなダイアログも出ました。 マクロでスタック領域が不足しています また、ダイアログで終了を押したらセルを正しく選択できなくなりました。 デバッグを押したら、停止ボタンを押すと応答なしになった後、Excelが終了し再起動しました。 そして、どちらを選択した場合でも、メニューや閉じるボタンを押してもExcelが終了できず、 タスクマネージャからプロセスを終了させるしかなかったです。 その時CPU使用率が50%を超えてたりと異常事態になっております。 ###標準モジュール### Sub all_feeCulc_change2(ByVal sheetName As String, ByVal row As Integer) If sheetName <> "" Then Dim customer As String customer = Worksheets(sheetName).Cells(row, 3) On Error Resume Next Dim book1 As Workbook '別ファイルのオープン(触らない) Workbooks.Open Filename:="hogehoge.xlsm" '別ファイルのオープン(触らない) Set book1 = Workbooks("hogehoge.xlsm") '別ファイルのオープン(触らない) On Error GoTo 0 Dim endrow As Integer '最終行番号 endrow = book1.Worksheets(customer).Cells(Rows.Count, 1).End(xlUp).row '最終行番号を取得 Dim hoge As Variant hoge = book1.Worksheets(customer).Range("A34:D" & endrow) '早見表から係数表をコピー With Worksheets(sheetName) ... ###ThisWorkbook### Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal target As Range) If target.Count = 1 Then Dim column As Integer Dim row As Integer column = target.column row = target.row If row >= 3 Then If ((column - 3) Mod 5) = 2 And column > 3 Then '更新セルがメーターだったら Call usageCulc_change(target.Parent.Name, target.column, target.row) Call all_feeCulc_change(target.Parent.Name, target.column - 1, target.row) Call chenge_tax_change(target.Parent.Name, target.column + 1, target.row) ElseIf column = 3 Then target.Value = format(target.Value, "000") '誤入力防止 Call all_feeCulc_change2(target.Parent.Name, target.row) Call chenge_tax_change2(target.Parent.Name, target.row) End If End If End If End Sub Private Sub Workbook_Open() '*****すべてのシート名を取得*****' Dim ws As Worksheet Dim sheetName() As String ReDim sheetName(3) Dim cnt As Integer cnt = 0 For Each ws In Worksheets If cnt > 3 And (cnt Mod 4) = 0 Then ReDim Preserve sheetName(UBound(sheetName) + 4) End If sheetName(cnt) = ws.Name cnt = cnt + 1 Next '*****取得終了*****' Dim endrow As Integer Dim line As Variant For Each line In sheetName If line <> "000" And line <> "" Then With Worksheets(line) endrow = .Cells(Rows.Count, 3).End(xlUp).row Dim i As Integer Dim j As Integer For i = 0 To endrow For j = 0 To 11 .Cells(3 + i, 4 + j * 5).NumberFormatLocal = "0.0" .Cells(3 + i, 5 + j * 5).NumberFormatLocal = "0.0" .Cells(3 + i, 6 + j * 5).NumberFormatLocal = "#,##0" .Cells(3 + i, 7 + j * 5).NumberFormatLocal = "#,##0" .Cells(3 + i, 8 + j * 5).NumberFormatLocal = "#,##0" Next j Next i End With End If Next End Sub

  • VBA エクセル 合計

    皆様、こんにちは。 それぞれの値が入っている会計シート(シートの形式は同じ)を一つの合計シートに合計しようとしていますが、うまくいきません。具体的に、数値の合計ができません。 例えば、ある項目に対して、シートAに100が入力され、シートBには230が入力されているとすれば、合計シートに100+230=330を入力したいです。なお、全ての会計シートは"Form"というエクセルシートにあり、その数をユーザが決めますので、検索しなければいけません。そして、合計シートは"Result"にあります。 以下のように書いてみましたが、間違っているようです。 Worksheets("Result").Activate Dim SR As Integer Dim SC As Integer 'SR is start row 'SC is start column SR = 6 SC = 2 Worksheets("Form").Activate Dim i As Integer i = 68 Do While 1 = 1 If Selection.Cells(i, 4).Value = "" Then Exit Do End If i = i + 49 Loop Sum = 0 Sum = Sum + Selection.Cells(i, 4) Worksheets("Result").Activate Cells(SR + 5, SC + 2) = Sum 詳しい方に教えていただければ非常に助かります。 どうぞよろしくお願いします。

  • Changeイベントに指示を加えたい

    こんにちは 現在ワークシートで下記マクロにて、日付・時間の履歴を自動入力しています。 3行目以降のC列のセルに何か入力すると、そのとなりのD列のセルに日付と時間が返されるものです。 Private Sub Worksheet_Change(ByVal Target As Range) Dim r As Integer, c As Integer r = Target.Row c = Target.Column If c < 3 Or c > 3 Or r < 3 Then End If Cells(r, c) <> "" Then Cells(r, c + 1) = Format(Now, "yyyy/m/d h:mm") Else Cells(r, c + 1) = "" End If End Sub この同一シートに、下記マクロの指示を加えたいのですが、うまくいきません。 3行目以降のE列のセルに "chcl" とすると、B列のセルに "機能回復" と自動入力されるものです。 Private Sub Worksheet_Change(ByVal Target As Range) Dim r As Integer, c As Integer r = Target.Row c = Target.Column If c < 5 Or c > 5 Or r < 3 Then End If Cells(r, c) = "chcl" Then Cells(r, c - 3) = Format("機能回復") Else Cells(r, c - 3) = "" End If End Sub まとめると・・・・・・ 3行目以降のC列のセルに何か入力すると、そのとなりのD列のセルに日付と時間が返され、 且つ、 3行目以降のE列のセルに "chcl" とすると、B列のセルに "機能回復" と自動入力される、 というシートが欲しいのです。 上記マクロ、それぞれ単発だと機能するのですが、一緒に出来ません。 どなたか、解決方法をご教授下さい。 よろしくお願いします。

  • VBA リストボックスについて

    VBA初心者です。どうぞよろしくお願いします。 ユーザーフォームにタブつきのリストボックスを作りたいと思っています。 リストはsheet1の中にあります。   A    B    C    D・・・ 1  NO  品名  売場 2  1  いちご  果物 3  2  みかん  果物 4  3  もも    果物 5  4  ハクサイ 野菜 6  5  キャベツ  野菜 7  6  きゅうり  野菜 8  7 9 果物のタブには、果物の品名が表示される。 1 いちご 2 みかん 3 もも 野菜のタブには、野菜の品名が表示される。 4 ハクサイ 5 キャベツ 6 きゅうり 青果のタブには、果物、野菜が表示される。 1 いちご 2 みかん 3 もも 4 ハクサイ 5 キャベツ 6 きゅうり 本を見ながら格闘しておりますが、きっと的違いで滅茶苦茶なことをしているのだと思います。 どうにも出来ず困っております。どなたか教えていただけないでしょうか。よろしくお願いします。 Private Sub UserForm_Initialize() Dim LastRow As Long Dim i As Integer Dim ListBoxNo As Integer Dim ListBox As Control Dim Listtabu(3) As Long 'タブの数 For i = 1 To 3 Listtabu(i) = 0 Next i Worksheets("sheet1").Activate With Worksheets("sheet1") LastRow = .Range("A65536").End(xlUp).Row For i = 2 To LastRow If Worksheets("sheet1").Range(Cells(i, 3)) = "果物" Then ListBoxNo = 1 Set ListBox = 果物 果物.List = Worksheets("sheet1").Range(Cells(i, 1), Cells(i, 2)).Value End If If Worksheets("sheet1").Range(Cells(i, 3)) = "野菜" Then ListBoxNo = 2 Set ListBox = 野菜 野菜.List = Worksheets("sheet1").Range(Cells(i, 1), Cells(i, 2)).Value End If If Worksheets("sheet1").Range(Cells(i, 3)) = "果物" & "野菜" Then ListBoxNo = 3 Set ListBox = 青果 青果.List = Worksheets("sheet1").Range(Cells(i, 1), Cells(i, 2)).Value End If ListBox.AddItem ListBox.List(Listtabu(LstBxNo), 0) = Worksheets("sheet1").Cells(i, 1).Value ListBox.List(Listtabu(LstBxNo), 1) = Worksheets("sheet1").Cells(i, 2).Value Listtabu(LstBxNo) = Listtabu(LstBxNo) + 1 Next End With End Sub

専門家に質問してみよう