• 締切済み

VBAで時間による処理判定

こんにちは。 エクセルVBAにて次のようなプログラムを作成しておりますが思考のループに入ってしまった為御助力をお願いします。 メインルーチンをキーボード「↑」が押されるまでループする。 その中で処理Aを1秒間隔、処理Bを5秒間隔、処理Cを30秒間隔に実行させる。 ※今回はサンプルコードの為DEBUG.PRINTを実行させる。 現状ループの中にApiSleepを入れ1/1000で制御しています。 処理を実行させると若干もたつきが感じられます。 正確な時間計測は必要としていませんのでシステム日付程度の精度を求めています。 方法は幾つかあると思いますがご協力をお願いします。 以下サンプルコード Public Type TestType   XTime As Integer   XBack As Integer End Type Sub Sample()   Dim KeyChk As Integer   'Dim ThisTime As Integer   Dim Ret1 As TestType   Dim Ret2 As TestType   Dim Ret3 As TestType   KeyChk = 0   With Ret1     .XTime = 1     .XBack = .XTime   End With   With Ret2     .XTime = 5     .XBack = .XTime   End With   With Ret3     .XTime = 30     .XBack = .XTime   End With   Do     KeyChk = GetAsyncKeyState(VK_UP)     Sleep (1000)     'ThisTime = ((Hour(Time) * 60) + Minute(Time) * 60) + Second(Time)     With Ret1       If .XTime = 0 Then         Debug.Print "処理A実行"         .XTime = .XBack       Else         .XTime = .XTime - 1       End If     End With     With Ret2       If .XTime = 0 Then         Debug.Print "処理B実行"         .XTime = .XBack       Else         .XTime = .XTime - 1       End If     End With     With Ret3       If .XTime = 0 Then         Debug.Print "処理C実行"         .XTime = .XBack       Else         .XTime = .XTime - 1       End If     End With   Loop While KeyChk = 0   MsgBox ("終了") End Sub API宣言及び仮想キー宣言は省略

みんなの回答

  • mitarashi
  • ベストアンサー率59% (574/965)
回答No.1

sleepの代わりにこんなのを見つけましたがいかがでしょうか http://support.microsoft.com/kb/231298/ja hTimer = CreateWaitableTimer(0, True, App.EXEName & "Timer") のところを、 hTimer = CreateWaitableTimer(0, True, Application.Name & "Timer") に変更したら、ご提示のコードのsleep(1000)のところを、wait(1)にして、動作いたしました。 実行中にワークシートを操作した感じでは、sleep(1000)と、DoEventsの組合せよりセル操作が軽快な気がします。但し、↑キーへの反応は鈍くなります。

avanzato
質問者

お礼

先のコードでは処理実行の判断としてカウントダウンを使用していましたが逆に実行時間を設定させインターバルを速くして精度を上げて見ました。 インターバルが速くなったことによりキー待ちの反応がかなり改善されました。 処理AからCを実際のコードに置き換え実行しましたがボチボチの反応でしたので現状で行きます。 ありがとうございました。

avanzato
質問者

補足

提示して頂いたコードですと確かにキー待ちの反応が悪くなりますね。 とりあえず別案を検討して見ます。

関連するQ&A

  • VBA null判定

    Accessでテキストボックスの値をテーブルへ書き込むVBAを作成しているのですが、Null判定がうまくいきません。 ◎環境 OS:Windows7Pro Var:Access2010 DB:MySQL5.6 Private Sub cmdSubmit_Click() Dim Rst As DAO.Recordset Dim ErrT As String Set Rst = CurrentDb.OpenRecordset("m_plan", dbOpenDynaset) '各テキストボックス、Null判定 If IsNull(txtPid) Then MsgBox "プランID[" & txtPid & "]が未入力です" Call txtCrer Exit Sub End If If IsNull(txtPName) Then MsgBox "プラン名が未入力です" Call txtCrer Exit Sub End If If IsNull(txtPsdate) Then Me!txtPsdate = #01/01/2010# End If If IsNull(Me!txtPedate) Then Me!txtPedate = #01/01/2010# End If Debug.Print "プランID["; Me.txtPid & "]" Debug.Print "プラン名[" & Me!txtPName & "]" Debug.Print "開始日[" & Me!txtPsdate & "]" Debug.Print "終了日[" & Me!txtPedate & "]" ↑↑↑↑↑↑↑↑↑ ここで、Null判定を行ってますが、データがあるにも関わらず、処理が続行されたり、Null判定結果が起動するたびに変わります。 On Error GoTo err With Rst .MoveLast .AddNew .Fields("PlanID") = Me!txtPid .Fields("PlanName") = Me!txtPName .Fields("PlanSt") = CDate(Me!txtPsdate) .Fields("PlanEn") = CDate(Me!txtPedate) .Fields("P_Remaks") = Me!txtPbikou .Update End With Rst.Close Set Rst = Nothing err: MsgBox "DBエラー" Debug.Print Rst.Type Debug.Print err.Description Call txtCrer End Sub ただし、下記判定だけのボタンとプロシージャーでは、正常に判定されます。 判定だけの、プロシージャー 'Null判定テスト Private Sub cmdtest_Click() If IsNull(txtPid) Then Debug.Print "[" & txtPid & "]" & "Nullです。" Else Debug.Print "[" & txtPid & "]" & "Not Nullです。" End If If IsNull(txtPName) Then Debug.Print "[" & txtPName & "]" & "Nullです。" Else Debug.Print "[" & txtPName & "]" & "Not Nullです。" End If If IsNull(txtPsdate) Then Debug.Print "[" & txtPsdate & "]" & "Nullです。" Else Debug.Print "[" & txtPsdate & "]" & "Not Nullです。" End If Debug.Print "===============================" End Sub どこが間違っているかまったくわかりません、アドバイスを頂けましたら幸いです。

  • うまく処理されません(ACCESSのVBA)

    イベント事業を管理するデータベースを作っています。 メインのテーブルを表示するフォームから、チェック(Yes/No型)された項目だけを抽出したクエリ「記事抽出」があります。 ここから、「行事名」「会場」「月1」「日1」という各フィールドのデータを以下のコードのように変数に代入していきたいのです。 チェックした数が少ないときはうまくいくのですが、20個くらいチェックすると、ループの途中で抜けてしまいます。このとき、エラーメッセージは表示されません。 原因として考えられることがあればお教えください。 説明が不足しているようでしたら、補足のほうで説明したいと思いますのでよろしくお願いします。 Dim cnn As New ADODB.Connection Dim rst As New ADODB.Recordset Dim i As Integer Dim gyouji(50) As String '行事名 Dim kaijyou(50) As String '会場 Dim tuki1(50) As Integer '月1 Dim nichi1(50) As Integer '日1 Set cnn = CurrentProject.Connection i = 0 With rst    .Open "記事抽出", cnn, adOpenKeyset, adLockOptimistic, adCmdTableDirect    Do Until .EOF      gyouji(i) = !行事名      kaijyou(i) = !会場      If IsNull(!月1) Then        tuki1(i) = 0      Else        tuki1(i) = !月1      End If      If IsNull(!日1) Then        nichi1(i) = 0      Else        nichi1(i) = !日1      End If      .MoveNext      i = i + 1    Loop    .Close End With cnn.Close

  • VBAで配列のNULL判定

    VBAで下記のように配列に設定したNULL値を判定しようとしました。 Dim str() ReDim Preserve str(2) str(0) = "aaa" str(1) = Null str(2) = "bbb" 以下(1)、(2)の分岐処理ではNullと判定されませんでした。 どのように判定すれば良いでしょうか? (1) If str(1) = Null Then Debug.Print "Null値です" End If (2) If str(1) = "" Then Debug.Print "Null値です" End If

  • VBAでの質問

    お世話になります。 下記の記述で、「←」の矢印の記述で、 Cells.(5,2)がブランクでなければ、 「→」から進めたいのですが、 どの様に記述すれば宜しいでしょうか ご教示お願いします。 Sub 表記入() Dim Data As Range Dim i As Integer Dim j As Integer Dim k As Integer Set Data = Sheets("集計").Range("A2").CurrentRegion j = 16 k = 0 With Sheets("表") For i = 3 To Data.Rows.Count If Data.Cells(i, 51) <> "" Then .Cells(5, 2) = Data.Cells(i, 3)  ← .Cells(5, 7) = Data.Cells(i, 4) → .Cells(j, 2) = Data.Cells(i, 10) .Cells(j, 6) = Data.Cells(i, 11) & Data.Cells(i, 12) .Cells(j, 14) = Data.Cells(i, 51) Else End If k = k + 1 If k = 10 Then j = j + 18 k = 0 Else j = j + 1 End If End If Next i End With End Sub

  • サブルーチンの処理

    すみませんが教えてください。 往年のF-BASICやN88などでは 10 INPUT A 20 IF A=1 then gosub 100 ELSE PRINT "Aは1ではありません!" 30 END 100 PRINT A 110 RETURN こんなふうだったかサブルーチンが使えたかと思います。 これをVB.NETでかくと Public Class Form1 Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click Dim A As Integer A = TextBox1.Text If A = 1 Then ここにどういれたらいいでしょう Else MsgBox("Aは1ではありません") End If End Sub End Class になるとおもうのですが、Thenのあとサブルーチンへ飛ばせるのでしょうか? それとも根本的に考え方が違うのでしょうか? 初歩的な質問ですみませんが、Timer1.Enable = Trueを使った処理以外 入門書に載っていないので、どなたかお教えいただけませんでしょうか。

  • vbaで正規表現

    正規表現のコードなんですが、 上手く動きません。 何故でしょうか… Sub Test() Dim reg As Object Dim ans As Object Dim c As Range         Set reg = CreateObject("VBScript.RegExp")     For Each c In Range("A1", Range("A" & Rows.Count).End(xlUp))             With reg             .Pattern = "^【[(1)-(20)](\d*/\d*)"             Set ans = .Execute(c.Value)         End With                 If ans > 0 Then             If Len(ans(0).submatches(0)) > 0 Then                             Debug.Print c.Address & "|" & ans(0).submatches(0)                             End If         End If             Next     End Sub

  • VBAについて

    以下のプログラムは、1年間の価格合計を求めるプログラムです。 これを実行するとうまくいくこともありますが、エラーが起きることもあります。 どうやら下記コードが原因のようなのですが、間違いがわかりません。 Target.Offset(0, 1).Value = run * (13 - month) どこが間違っているのでしょうか。 また最終的に、A行かB行のどちらかが更新されたときにこのプログラムを 実行させたいのですが、方法がわかりません。 無知な質問ではありますが、どなたか教えてください。 --------------------------------------------------------- Private Sub Worksheet_Change(ByVal Target As Range) Dim month As Integer Dim run As Integer If Intersect(Target, Range("A25:A35")) Is Nothing Then Exit Sub Else If Target.Offset(0, -2).Value <> "" Then month = Target.Offset(0, -2).Value month = month - 3 If month = -2 Then month = 10 ElseIf month = -1 Then month = 11 ElseIf month = 0 Then month = 12 End If run = Target.Offset(0, 0).Value Target.Offset(0, 1).Value = run * (13 - month) End If End If End Sub

  • Excel VBA ・・・教えてください

    何度も質問させて頂いてます。すみません、 下記のプログラムはこの場で教えて頂いたプログラムで、 実行すると●の後を▲や■が追いかける動きをします。 下記のプログラムをある程度使用して 1~20の数字が順々で追いかけっこする プログラムを作成するにはどのようにすればいいのでしょうか… できればプログラムは長めにならず 20の数字から簡単に増やすことのできるような そんなプログラムが作成したいです… どなたかアドバイスお持ちの方 教えて下さいお願いします... Dim time1 As Integer, time As Integer Dim X As Integer, Y As Integer Dim X1 As Integer, Y1 As Integer Dim X2 As Integer, Y2 As Integer Dim maru As String, yoko As String, tate As String Dim sankaku As String, shikaku As String Sub 描画() Cells(Y2, X2).Value = shikaku Cells(Y1, X1).Value = sankaku Cells(Y, X).Value = maru End Sub Sub 削除() Cells(Y2, X2).Value = "" End Sub Sub 待機() For time1 = 0 To 1000 For time2 = 0 To 1000 Next Next End Sub Sub 座標移動() X2 = X1 Y2 = Y1 X1 = X Y1 = Y If yoko = "右" Then X = X + 1 Else X = X - 1 End If If X = 30 Then yoko = "左" ElseIf X = 1 Then yoko = "右" End If If tate = "上" Then Y = Y + 1 Else Y = Y - 1 End If If Y = 20 Then tate = "下" ElseIf Y = 1 Then tate = "上" End If End Sub Sub main() maru = "●" sankaku = "▲" shikaku = "■" X = 1 Y = 1 X1 = 1 Y1 = 1 X2 = 1 Y2 = 1 yoko = "右" tate = "上" Do 描画 待機 削除 待機 座標移動 Loop End Sub

  • access VBA処理がうまくいかない

    お世話になります。 T_請求に追加する追加クエリQ_家賃請求Tがあります。 どの物件を更新するかをチェックボックスで指定し、追加クエリの抽出条件にしています。 月に1度のみの操作ですが、数人でこのデータベースを触り、 何度も追加されると困るので2度目以降はエラー処理をさせたいと思っています。 Private Sub 更新_Click() Dim ret As Integer ret = MsgBox("チェック物件を請求更新します。" & vbCrLf & "よろしいですか?", _ vbYesNo + vbQuestion, "請求月次更新") If ret = vbYes Then If DCount("[契約者CD]", "[T_請求]", "[物件CD] = " & Me!物件CD & _ " AND [T_請求]![請求年月] > #" & DateSerial(Year(Date), Month(Me![処理日]) + 1, 1) & "#") _ <> 0 Then MsgBox "すでに指定物件の請求は更新されています" & vbCrLf & _ "同じ月に請求を2度更新できません" Else DoCmd.SetWarnings False DoCmd.OpenQuery "Q_家賃請求用T" MsgBox "更新されました" DoCmd.SetWarnings True End If Else If MsgBox("処理を中止しました", vbOKOnly + vbDefaultButton1 + vbExclamation) = vbOK Then Me.Undo Cancel = True End If End If End Sub 以上のようなコードを書きました。 処理が正しくできているか確認のために、動作を調べたのですが、 まったく同じ請求年月で同じ物件CDのものが保存先のテーブルに処理されてしまいます。 どの部分を直せばいいのでしょうか? 足りない情報があれば提示しますので、よろしくお願いいたします。

  • vbaの繰り返し処理について

    vbaです。 Sub Test1() Dim Str As String Dim Pnt1 As Long Dim Pnt2 As Long Str = Range("A1") Pnt1 = InStr(Str, "重 http://") If Pnt1 <= 0 Then Exit Sub Pnt2 = InStr(Pnt1, Str, "要") If Pnt2 <= 0 Then Range("B1") = Mid(Str, Pnt1 + 2) Else Range("B1") = Mid(Str, Pnt1 + 2, Pnt2 - (Pnt1 + 2)) End If End Sub という式でA1からA2.A3と下にURLが入っており空欄になるまで同じ処理をしたいのですがどのように変更すれば作動しますでしょうか?

専門家に質問してみよう