• ベストアンサー

処理中メッセージを出しておきたいのですが

ある処理を実行するのに実行中ユーザーフォームで%表示をして終了と同時に閉じるVBAを・・コードは次のようにしています。 Sub 転記() Dim strCode As String Dim rngSA As Range Dim rngFC As Range strCode = Application.InputBox("受付番号は", "番号の入力",   Type:=2)   UserForm2.Show vbModeless 'キャンセルの場合の処理 If UCase$(strCode) = "FALSE" Then Exit Sub '受付番号の検索範囲を取得 With Sheets("sheet") Set rngSA = .Range("A1", .Range("A65536").End(xlUp)) End With '受付番号の検索範囲から入力された受付番号を探す Set rngFC = rngSA.Find(What:=strCode, LookAt:=xlWhole) '該当する受付番号が無ければ警告を表示して終了 If rngFC Is Nothing Then MsgBox "番号がありません!", vbOKOnly Or vbCritical, "エラー" Exit Sub End If '該当番号があった場合、氏名等転記 With Sheets("sheet2") .Range("F31").Value = rngFC.Offset(0, 4).Value 'TEL .Range("F29").Value = rngFC.Offset(0, 1).Value '氏名 End With '後始末:変数をクリア Set rngFC = Nothing Set rngSA = Nothing 'メッセージ用のユーザーフォームを閉じる UserForm2.Hide '転記成功メッセージを表示 MsgBox "終わりました。", vbInformation End Sub

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

  • ベストアンサー
  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.4

hirosatonn さんへ >コードなど載せないで、簡単に質問すればよかったと反省しています。 こうしたテクニックは知っていてもある程度の経験のある人は、テクニックと実際の実務とどちらを取るかというと、実際の実務になってしまいます。某有名なExcelアドインなどは、確かにプログレスバーなどもついていて、見栄えがいいので、初心者「ウケ」をするようなのですが、そのコードを知っている身になると、メモリ食いのExcelに贅沢なものは要らない、ということが、優先してしまいます。これも、知っているからこその拒否反応のようなものなのですね。 ところで、プログレスバーというのは、Excel VBAの場合は、ラベルを代用して色を変えるだけなんです。VBのように、専用のコントロールがあるわけではありません。 http://oshiete1.goo.ne.jp/kotaeru.php3?q=405615 の#3 の方は、ネットの引用のルールからしたら、その元を書かなくてはならないはずです。それは、ここにあります。 『かんたんプログラミング Excel VBA コントロール・関数編』大村あつし著 (技術評論社) 第二章の中の、「ラベルをプログレスバーとして利用する」 >コマンドボタンを押さないでUserFormが現われた状態では駄目なんでしょうね。 上記のものをそっくり写して、UserForm_Initialize() イベントで動かせばよいです。 %表示をプログレスバーの中に入れるなら、下側になるラベルにでも、Caption で表示させれば良いと思います。

hirosatonn
質問者

お礼

返事が遅れましてすみません。だいたい思っていたようなものが出来ました。いつも感謝しています。

hirosatonn
質問者

補足

>UserForm_Initialize() イベントで動かせばよいです 未熟なのでよく分かっていませんが、標準モジュールでの処理?ですかネ。 馬鹿な質問ですみません。

その他の回答 (3)

  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.3

こんばんは。 ふつうは、処理中やプログレスバーの表示というのは、Userform 設定時に、ちょうど、フリーズした状態にみえるので、それでつけるわけです。それで、 コードの内容からして、仮に時間が掛かったとしても、たかが数秒のことで、それで、%(パーセンテージ)表示が必要な部分があるのか疑問に感じています。私も、かつてプログレスバーで使ったことがあるけれど、最終的には、単に、テキストボックスに、「読み込み中」の表示を出すだけで終わってしまいました。 どこに、時間が掛かって、「処理中」の表示が必要なのか、お分かりになりますか? プロシージャ名に「転記」とありますから、ループするのだろうと思いますが、それが書かれていません。今のままのコードでは、%(パーセンテージ) やプログレスバーをつける余地がありません。

hirosatonn
質問者

補足

いつも未熟な私の質問に色々とお答え頂きありがとうございます。 ご指摘のとおり今回のコード(だいぶ省略していますが)ではほとんど必要の無いのですが、別のVBA処理の中でUserForm2.Show vbModeless を使っており、「お待ちください・・・」と表示されるだけなのでプログレスバー(今回皆さんからのご指導ではじめて知りました。)で%表示がでないかなと思った次第です。 コマンドボタンを押さないでUserFormが現われた状態では駄目なんでしょうね。 コードなど載せないで、簡単に質問すればよかったと反省しています。

  • 0shiete
  • ベストアンサー率30% (148/492)
回答No.2

プログレスバーを表示させたいのでしょうか? 下記をどうぞ

参考URL:
http://oshiete1.goo.ne.jp/kotaeru.php3?q=405615
hirosatonn
質問者

お礼

URLありがとうございます。大変参考になりました。

  • hana-hana3
  • ベストアンサー率31% (4940/15541)
回答No.1

処理内容としてはそのようなメッセージを表示させるほどの時間が掛かるような事は無いと思いますが・・・。 何が出来ないのでしょうか?

hirosatonn
質問者

お礼

はい。すみません。そのとおりです。 UserFormを出した時に%がでないかなと思いまして。 質問の意図が分かりづらいコードの載せまして、ごめんなさい。 お答え頂きありがとうございました。

関連するQ&A

  • インプット関数を使って・・(応用)

    インプット関数を使って・・でご教授頂き、解決したのに複雑になったら何故か転記できません。すみませんが、ふたたびご教授をいただきたいです。 シート1(データシート) A列に通し番号(80001,80002,・・)B列に氏名、C列以降もデータがあり J列に電話番号があります。インプットボックスに通し番号(80001などの番号)を入力すると80001に対応する氏名を(B29へ)、電話番号を(F29へ)としたいのですが、シート2(転記シート)へが表示できません。(一応「転記しました」と表示するのですが?) データシートの2行目に項目、3行目からデータが入っています。 Sub 転記() Dim Numv As Variant Dim FindNum As Long Dim wsNum As Long Dim sNumv As Range '検索する受付番号を取得 FindNum = InputBox("受付番号は", "番号の入力") 'キャンセルの場合の処理 If Len(Trim(FindNum)) = 0 Then Exit Sub '"受付番号"列番号の自動取得 Set sNumv = Worksheets("データシート").Cells.Find(What:="受付番号") '該当する受付番号は見つかったか? If sNumv Is Nothing Then MsgBox "受付番号がありません!", vbOKOnly, "エラー" 'プログラム終了 Exit Sub Else End If '該当番号があった場合転記 With sNumv .Copy.Offset(0, 2).Value = Worksheets("転記シート").Range("B29").Value .Copy.Offset(0, 10).Value = Worksheets("転記シート").Range("F29").Value End With '転記成功メッセージを表示 MsgBox "転記しました", vbInformation Worksheets("転記シート").Select End Sub

  • 特定の文字以外を入力すると別シートに表記する方法

    Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim StrRow As Long Dim TgtCol As Long Dim MaxRow As Long Dim ChgRow As Long Dim PutSh1 As Worksheet Dim PutSh2 As Worksheet Dim PutSh3 As Worksheet Dim PutCol As Long Dim PutRow As Long Dim ChgRng1 As Range Dim ChgRng2 As Range Dim ChgRng3 As Range StrRow = 5 MaxRow = 35 If Target.Count > 1 Then Exit Sub If Target.Value = "" Then Exit Sub Set PutSh1 = ThisWorkbook.Sheets("Sheet2") Set PutSh2 = ThisWorkbook.Sheets("Sheet3") Set PutSh3 = ThisWorkbook.Sheets("Sheet4") With ThisWorkbook.Sheets("Sheet1") Set ChgRng1 = Range(.Cells(StrRow, 3), .Cells(MaxRow, 3)) 'C列 Set ChgRng2 = Range(.Cells(StrRow, 5), .Cells(MaxRow, 5)) 'E列 Set ChgRng3 = Range(.Cells(StrRow, 7), .Cells(MaxRow, 7)) 'G列 End With ChgRow = Target.Row If Not Intersect(Target, ChgRng1) Is Nothing Then Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1 DataPut PutSh1, ChgRow, Target.Value End If If Not Intersect(Target, ChgRng2) Is Nothing Then Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1 DataPut PutSh2, ChgRow, Target.Value End If If Not Intersect(Target, ChgRng3) Is Nothing Then Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + 1 DataPut PutSh3, ChgRow, Target.Value End If End Sub 以前質問させて頂いた内容で追加の質問です。 Sheet1の指定したセルに「ー(ハイフン)」の文字がある時は、Sheet2〜4に転送(表記)しない方法を追加する場合はどの様にすれば宜しいでしょうか?

  • エクセルの簡単なマクロ機能を追加したいのです

    既存のエクセルマクロ(Sub チェック()以下です)に下記の内容のマクロを付け足したいです。 教えていただけないでしょうか。 付け足したい条件です:  Sheet2のC列に 0  があれば  Sheet1のB列に 愛 と([太字]でセルの背景色を[灰色25%]にして)入れたいです 恐れ入りますがご存じの方がいらっしゃりましたら教えていただきたく何卒よろしくお願いいたします。 ----------------------------------------------- Sub チェック() Dim Ws1 As Worksheet Dim Ws2 As Worksheet Dim myRange1 As Range Dim myRange2 As Range Dim c1 As Range Dim c2 As Range Dim myCt As Long Set Ws1 = Worksheets("Sheet1") Set Ws2 = Worksheets("Sheet2") Set myRange1 = Ws1.Range("A1", Ws1.Cells(Rows.Count, "A").End(xlUp)) Set myRange2 = Ws2.Range("A1", Ws2.Cells(Rows.Count, "A").End(xlUp)) For Each c1 In myRange1 myCt = 0 For Each c2 In myRange2 If c2.Value = c1.Value Then If c2.Offset(, 1).Value = "" Then c1.Offset(, 1).Interior.ColorIndex = 3 Else c1.Offset(, 1).Value = c2.Offset(, 1).Value End If myCt = myCt + 1 End If Next c2 If myCt > 1 Then c1.Offset(, 1).Interior.ColorIndex = 10 Next c1 Set Ws1 = Nothing Set Ws2 = Nothing Set myRange1 = Nothing Set myRange2 = Nothing End Sub

  • 2つブック IDが重複しても転記を行う方法

    2つのブックでIDが一致したら 横にある文字を転記するというマクロがあるのですが 同じIDが続いても転記先のエクセルに全て転記したいのですが IFか ELSE CASEで条件分岐させればよろしいのでしょうか? 下記にマクロのコードと構成と画像を記述させて頂きます お手数ですがご教授して頂けないでしょうか? 恐縮ですがよろしくお願いいたします。 Sub 転記() Dim w0 As Worksheet, w1 As Worksheet Dim h As Range, Target As Range Set w0 = Workbooks("IDデータ.xls").Worksheets(1) Set w1 = Workbooks("ID管理票.xls").Worksheets(1) For Each h In w0.Range("A2:A" & w0.Range("A65536").End(xlUp).Row) Set Target = w1.Range("D11:D60000").Find(what:=h.Value, LookIn:=xlValues, lookat:=xlWhole) If Not Target Is Nothing Then Select Case h.Offset(0, 1).Value Case "確認" Target.Offset(0, -1) = h.Offset(0, 1).Value Case Else End Select End If Next End Sub

  • エクセルのVBAコードにつてい

    以下のコードについて、その内容をまだ自分の知識では理解できず困っておりまして、アドバイスいただければと思いまして書き込みました。 『コード』 Sub Test() Dim Lc As Integer Dim Ct As Integer Dim MyR As Range Dim C As Range Dim D As Range Lc = Range("A1").End(xlToRight).Column - 2 For Each C In Range("B2", Range("B65536").End(xlUp)) Ct = WorksheetFunction.Count(C.Offset(, 1).Resize(, Lc)) If Ct > 0 Then Set MyR = C.Offset(, 1).Resize(, Lc).SpecialCells(2, 1) For Each D In MyR With Sheets("Sheet2").Range("A65536").End(xlUp) .Offset(1).Value = C.Value .Offset(1, 1).Value = Cells(1, D.Column).Value End With Next Set MyR = Nothing End If Next With Sheets("Sheet2") .Columns("A:B").AutoFit .Activate End With End Sub 『質問』 1.「Lc = Range("A1").End(xlToRight).Column - 2」の部分の解釈は「A1から右方向に一番最後のセルまでを範囲指定し、その一番右のセルの列番号を取得する」変数という解釈でいいのか 2.「Ct = WorksheetFunction.Count(C.Offset(, 1).Resize(, Lc))」の部分の変数はどういった値の整数を取得する変数なのか 以上2点についてアドバイスいただけると幸いです。

  • ユーザーフォームの値の重複登録を中止するには

    UserForm1の登録ボタン(CommandButton2)を押したときに、フォーム上の会社番号及び注文番号の二つの数値を参照して、Sheet1上の会社番号と注文番号の列から、すでに同じ会社番号で同じ注文番号が登録されてないか確認します。 例えば、フォーム上の会社番号2で注文番号104は、シート上でも会社番号2で注文番号104があるため、msgbox "既に登録済みです"を表示させて登録を中止するにはどうすれば良いでしょうか。 現状、登録ボタンを押しと時に実行させる処理は以下の通りです。 Private Sub CommandButton2_Click() Dim rc As Integer rc = MsgBox("記録を保存しますか?", vbYesNo + vbQuestion, "保存") If rc = vbYes Then If TextBox1.Value = "" Or TextBox2.Value = "" Or TextBox3.Value = "" Or TextBox4.Value = "" Then MsgBox "未入力な項目があります。" Else Dim tr As Range Set tr = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) tr.Offset(0, 0).Value = UserForm1.TextBox1.Value tr.Offset(0, 1).Value = UserForm1.TextBox2.Value tr.Offset(0, 2).Value = UserForm1.TextBox3.Value tr.Offset(0, 3).Value = UserForm1.TextBox4.Value MsgBox "保存しました。" End If Else MsgBox "キャンセルしました。" End If End Sub

  • 処理時間がかかりすぎます

    いろいろ調べながらマクロを書いたのですが時間がかかりすぎます。 どのうようにすれば時間短縮が図れるのでしょうか。 Sub sample() Dim tuki As Integer Dim bango As Integer Dim tukihi As Integer Dim c As Range For tuki = 1 To 12 For bango = 11 To 1000 For tukihi = 14 To 19 With Worksheets(Format(tuki) & "月").UsedRange.Rows(3) Set c = .Find(what:=Worksheets("年間予定表").Cells(bango, tukihi).Value, LookIn:=xlValues, LookAt:=xlWhole) If Not c Is Nothing Then Worksheets("年間予定表").Range("N1") = c.Address Worksheets(Format(tuki) & "月").Range(c.Address).Offset(bango - 3, 0) = _ Worksheets("年間予定表").Cells(bango, 3).Value & _ Worksheets("年間予定表").Cells(bango, 2).Value & _ " , " _ & Worksheets("年間予定表").Cells(bango, 21).Value End If End With Next tukihi Next bango Next tuki End Sub Sub youbi_s

  • 入力規則のドロップダウンリストを連動

    以下のサイトを参考に別ブックからデータを参照する方法で苦戦しています。 http://www.eurus.dti.ne.jp/yoneyama/Excel/vba/vba_validation.html Sub name_1()   Dim lCol As Long, lRow As Long   Dim i As Long, nName As String Dim Wb As Workbook ←追記 Set Wb = Workbooks("MyBook.xls") ←追記     On Error Resume Next     With Wb.Sheets("Sheet2")       lCol = .Range("A1").End(xlToRight).Column       ActiveWorkbook.Names("項目リスト").Delete       ActiveWorkbook.Names.Add Name:="項目リスト", _         RefersTo:=.Range(.Cells(1, 1), .Cells(1, lCol))       '----名前の定義       For i = 1 To lCol         lRow = .Cells(1, i).End(xlDown).Row         nName = .Cells(1, i).Value         ActiveWorkbook.Names(nName).Delete         .Range(.Cells(1, i), .Cells(lRow, i)).CreateNames Top:=True       Next i     End With End Sub Sub Macro2()   name_1   With Range("A2:A10").Validation     '--入力規則を削除     .Delete     '--入力規則を設定     .Add Type:=xlValidateList, _       Formula1:="=項目リスト"   End With   '--B2セルへ入力規則を設定   With Range("B2:B10").Validation     .Delete     .Add Type:=xlValidateList, _       Formula1:="=IF(A2="""",A2,INDIRECT(A2))"   End With End Sub Private Sub Worksheet_Change(ByVal Target As Range)   Dim c As Range Dim Wb As Workbook ←追記 Set Wb = Workbooks("MyBook.xls") ←追記     If Not (Application.Intersect(Target, Range("A2:B10")) Is Nothing) Then     name_1     Application.EnableEvents = False       If Target.Column = 1 Then         If Target.Value = "" Then           Target.Offset(0, 1).Value = ""         Else           Set c = Wb.Sheets("Sheet2").Range(Target.Value).Find(Target.Offset(0, 1).Value, lookat:=xlWhole) ←ここでエラー           If c Is Nothing Then             Target.Offset(0, 1).Value = ""           End If         End If       End If       If Target.Column = 2 Then         If Target.Value = "" Then           Target.Offset(0, -1).Value = ""         End If       End If     Application.EnableEvents = True     End If End Sub どのように改変すれば良いのでしょうか?

  • 処理速度を速くする方法教えてください。

    Private Sub CommandButton1_Click() Dim irow As Long Dim Celldata(1 To 6) As Double Dim ekimen(1 To 6) As String '高さ読込み If TextBox8.Value = "" Then MsgBox ("No.を入力") End End If If TextBox9.Value = "" Then MsgBox ("温度を入力") End End If If TextBox10.Value = "" Then MsgBox ("係数を入力") End End If Celldata(1) = TextBox1.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value Celldata(2) = TextBox2.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value Celldata(3) = TextBox3.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value Celldata(4) = TextBox4.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value Celldata(5) = TextBox5.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value Celldata(6) = TextBox6.Value + (TextBox7.Value - TextBox9.Value) * TextBox10.Value '入力と修正 Dim i As Long '最終行から試験Noが一致するものを探す For i = 65535 To 6 Step -1 If CStr(Cells(i, 1)) = Trim(TextBox8.Value) Then Set myrange = Sheets("データ").Cells(i - 1, 1) '記入セルがoffset(1,x)になっているため、i-1にしています。 Exit For End If Next i 'Noが一致しない場合、最終行を記入セルに設定する。 If i = 5 Then Set myrange = Sheets("データ").Range("A65536").End(xlUp) End If 'ワークシートへの転記 With myrange .Offset(1, 0).Value = TextBox8.Value '----No. .Offset(1, 1).Value = Celldata(1) '----1計測 .Offset(1, 2).Value = Celldata(2) '----2計測 .Offset(1, 3).Value = Celldata(3) '----3ル計測 .Offset(1, 4).Value = Celldata(4) '----4計測 .Offset(1, 5).Value = Celldata(5) '----5計測 .Offset(1, 6).Value = Celldata(6) '----6計測 .Offset(1, 13).Value = TextBox1.Value '----1追加 .Offset(1, 14).Value = TextBox2.Value '----2追加 .Offset(1, 15).Value = TextBox3.Value '----3追加 .Offset(1, 16).Value = TextBox4.Value '----4追加 .Offset(1, 17).Value = TextBox5.Value '----5追加 .Offset(1, 18).Value = TextBox6.Value '----6追加 .Offset(1, 19).Value = TextBox7.Value '---温度 .Offset(1, 20).Value = TextBox11.Value '----1高さ .Offset(1, 21).Value = TextBox12.Value '----2高さ .Offset(1, 22).Value = TextBox13.Value '----3高さ .Offset(1, 23).Value = TextBox14.Value '----4高さ .Offset(1, 24).Value = TextBox15.Value '----5高さ .Offset(1, 25).Value = TextBox16.Value '----6高さ '入力ボックスのクリア TextBox1.Value = "" '----1セル TextBox2.Value = "" '----2セル TextBox3.Value = "" '----3セル TextBox4.Value = "" '----4セル TextBox5.Value = "" '----5セル TextBox6.Value = "" '----6セル TextBox7.Value = "" '---温度 TextBox11.Value = "" '----1セル TextBox12.Value = "" '----2セル TextBox13.Value = "" '----3セル TextBox14.Value = "" '----4セル TextBox15.Value = "" '----5セル TextBox16.Value = "" '----6セル End With 'lblComment.Caption = "ワークシートに転記しました!" End Sub Private Sub CommandButton2_Click() Dim i As Long '入力チェック If TextBox8.Value = "" Then MsgBox ("No.を入力") End End If If TextBox9.Value = "" Then MsgBox ("温度を入力") End End If If TextBox10.Value = "" Then MsgBox ("係数を入力") End End If For i = 65535 To 6 Step -1 If CStr(Cells(i, 1)) = Trim(TextBox8.Value) Then Set myrange = Sheets("データ").Cells(i - 1, 1) '記入セルがoffset(1,x)になっているため、i-1にしています。 Exit For End If Next i '受付No.がない場合、終了します。 If i = 5 Then MsgBox ("No.が見つかりません") End End If '入力の処理と逆の処理を行います。 With myrange TextBox1.Value = .Offset(1, 13).Value '---1計測 TextBox2.Value = .Offset(1, 14).Value '---2計測 TextBox3.Value = .Offset(1, 15).Value '---3計測 TextBox4.Value = .Offset(1, 16).Value '---4計測 TextBox5.Value = .Offset(1, 17).Value '---5計測 TextBox6.Value = .Offset(1, 18).Value '---6計測 TextBox7.Value = .Offset(1, 19).Value '---温度 TextBox11.Value = .Offset(1, 20).Value '---1高さ TextBox12.Value = .Offset(1, 21).Value '---2高さ TextBox13.Value = .Offset(1, 22).Value '---3高さ TextBox14.Value = .Offset(1, 23).Value '---4高さ TextBox15.Value = .Offset(1, 24).Value '---5高さ TextBox16.Value = .Offset(1, 25).Value '---6高さ End With End Sub

  • 変数で指定したセルの値を取得して計算させるには?

    sub 単月発生残高の取得() Windows("総勘定元帳データ").Activate Worksheets(1).Activate Range("a2").Activate Dim sRange As Range, eRange As Range, tRange As Range, uRange As Range Dim j As Long, k As Long Dim i As Integer For i = 3 To Range("a2").End(xlDown).Row Set sRange = Cells(i, 1) Set eRange = sRange.End(xlToRight) Set tRange = eRange.Offset(2, 0) Set uRange = tRange.Offset(0, -1) j= tRange.value k= uRange.value Range("B1").formula="=k-j" Range("A1").value="単月発生残高" Next Set sRange = Nothing Set eRange = Nothing Set tRange = Nothing Set uRange = Nothing End Sub 上記のマクロを組んでみましたが、j= tRange.value のところでエラーになります。 uRangeの値からtRangeの値を引いた値を"B1"に表示させたいのですが、うまくいきません。 どうすればいいでしょうか。

専門家に質問してみよう