ある処理を行うときに、処理中はポインタを砂時計にするには

 Screen.MousePointer = vbHourglass
  処理内容
 Screen.MousePointer = vbDefault

にしますが、砂時計の代わりに、ランプを赤で表示するにはどうしたら
いいのですか?(処理が終わったら黒で表示)

 Shape1.FillColor = &HFF
  処理内容
 Shape1.FillColor = &H0&

でいけると思ったのですが、どうやら、完全に処理が終わらないと、
色が変化してくれないようなので・・・・。(黒のまま)
なにかいい方法があったら教えてください。(Shapeでなくても可)

A 回答 (1件)

こんにちは、honiyonです。



Shape1.FillColor = &HFF
DoEvents
^^^^^^^^
  処理内容
Shape1.FillColor = &H0&

 としてみてはいかがでしょうか?
 
 外していたらごめんさない(..
    • good
    • 0
この回答へのお礼

アドバイスどおりで出来ました!!
ありがとうございました。。。m(._.)m
また機会があったらよろしくお願いいたします。
それでは。

お礼日時:2001/07/24 13:05

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

Q砂時計の不思議

今日お茶を飲みに行ったお店に1分、3分、5分の3つが一緒になっている砂時計がありました。

1分の砂時計がすべて落ち終わった時点で、すぐひっくり返したところ、1分→5分→3分の順で終わりました。何度やっても同じ結果でした。

どうして同時に終わらないのですか?

3つの砂時計はひとつになっているので、ひっくり返す時間がずれたということはありません。

私は数学はホントに苦手なので、なぜこうなったのか全く検討もつきません。この1分→5分→3分という結果になったのはどういうことなんでしょうか?砂時計がおかしかったんですか?

Aベストアンサー

砂時計は細い穴を通じて上から下へ砂が落ちるものですが、砂の落ちる速さが一定でないと思われます。たとえばですが、最初はゆっくり、だんだん落ちる速さが速くなって、またゆっくりになってきて、最後の一粒が落ちる。こんな感じなんだと思います。上に残っている砂の量によって圧力が変わってくるからでしょうか。
だから、3分や5分の砂時計で1分間に落ちた砂の量は、ひっくり返しても、同じ速さで落ちるわけではないので(ゆっくりになる)、そのような結果になったのだと思われます。
説明が下手ですみません(^^;

Q処理終了後のに砂時計が、クリックしないと矢印に

 高速処理ができるようにしたのはいいのですが、マウスポインタの砂時計がクリックしないと矢印に戻りません。自分のパソコンでは、クリックしないで戻るのですが。会社のパソコンだとできません。スッペクの良し悪しなのか、スペックに関係なくクリックしないで矢印に戻る解決方法があればお願いします。(コードは下記です。)

Windows7 Office2010

Private Sub 定義の書込_Click()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


Dim ret As Integer

ret = MsgBox("メインシートのデータを、" & ActiveSheet.Range("C54").Value & "の勤務表に" _
& "書き込みます。 よろしいですか?", _
vbOKCancel + vbQuestion, "メイン・2")

Select Case ret
Case vbOK

UserForm2.Show vbModeless
UserForm2.Repaint

Dim i As Integer
Dim j As Integer
For i = 1 To 16
For j = 1 To 31
Dim addrname_workpattern As String
addrname_workpattern = ""
With Worksheets("メイン")
Select Case .Cells(9 + (i - 1) * 2, 10 + (j - 1) * 3).Value
Case 1: addrname_workpattern = "勤務1"
Case 2: addrname_workpattern = "勤務2"
Case 3: addrname_workpattern = "勤務3"
Case 4: addrname_workpattern = "日勤1"
Case 5: addrname_workpattern = "日勤2"
Case 6: addrname_workpattern = "日勤3"
Case Else
Select Case .Cells(10 + (i - 1) * 2, 9 + (j - 1) * 3).Value
Case 1: addrname_workpattern = "日勤4"
Case Else
Select Case .Cells(9 + (i - 1) * 2, 9 + (j - 1) * 3).Value
Case 2: addrname_workpattern = "明け"
Case 3: addrname_workpattern = "日勤"
Case 4: addrname_workpattern = "夜勤"
Case 5: addrname_workpattern = "公"
Case 6: addrname_workpattern = "有"
Case 7: addrname_workpattern = "特"
Case 8: addrname_workpattern = "振"
Case 9: addrname_workpattern = "欠"
End Select
End Select
End Select
End With
If addrname_workpattern <> "" Then
ActiveSheet.Range(addrname_workpattern).Copy
Cells(7 + i, 5 + (j - 1) * 3).PasteSpecial
Application.CutCopyMode = False
End If
Next
Next

Unload UserForm2

Range("E10:CS10").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("E34:CS34").Select
Selection.Delete Shift:=xlUp

Macro9

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Select
End Sub

 高速処理ができるようにしたのはいいのですが、マウスポインタの砂時計がクリックしないと矢印に戻りません。自分のパソコンでは、クリックしないで戻るのですが。会社のパソコンだとできません。スッペクの良し悪しなのか、スペックに関係なくクリックしないで矢印に戻る解決方法があればお願いします。(コードは下記です。)

Windows7 Office2010

Private Sub 定義の書込_Click()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


Dim ret As Integer

ret = MsgBox("...続きを読む

Aベストアンサー

最後に以下の処理を入れてみては如何でしょうか。

Application.Cursor = xlDefault

Q砂時計はどこで買えますか?

こんにちは。
砂時計ってどこで買えるのでしょうか?
100円ショップなどにありますか?

それと、去年放送したドラマ 砂時計で使用された砂時計はサンドミュージアムに行けばあるのでしょうか?
いくらぐらいするかご存知の方は教えてください。
それとサンドミュージアムの入場は無料なんでしょうか?

お待ちしています。

Aベストアンサー

100円ショップにあります。

QVB で =Right([nendo],2) & "/06" はどういう事ですか?Right([nendo],2)は?

VB で =Right([nendo],2) & "/06" はどういう事ですか?Right([nendo],2)は?

Aベストアンサー

&amp;="&"
&amp;="""
=Right([nendo],2) &amp; &quot;/06&quot  -> =Right([nendo],2) & "/06"
[nendo]はアクセスのフィールド名か(アクセスのVBA?)。[]で囲むから。
中身は、#2でご指摘の年度で2007とかは行っているのでしょう。
Right関数は文字列の右側、最後から文字数を指定して切り出す。
&は文字列を結合する演算子。
/06をこの順序で結合するもの。

Q砂時計を自由落下させるとどうなるでしょうか?

スカイダイバーが、上空3000メートルから飛び降りるときに、砂時計を持って落ちます。
すると、砂が落ちきるまでの時間は、地上での砂時計と比べて、長くなるのでしょうか?短くなるのでしょうか?

また、上空3000メートルから砂時計だけを、垂直を保つようにしながら自由落下させたときはどうでしょうか?

空気のあるなしでは、それらに違いはあるでしょうか?

自由落下ではなく、地球上と月面上で比べたらどうなるのでしょうか?

物理は高校までの知識しかありません。どうぞよろしくお願いいたします。

Aベストアンサー

結論としては、砂時計の“形状”などにより、早くもなり遅くもなります。

「砂時計」はご存知の通り、地球上の1Gの環境で、一定の時間に落ちるように砂の量を調整して封入されています。
そして砂時計の“クビレ”の部分を通る砂は、「ゲート理論(?)」により、“抵抗”が与えられています。
その部分の力学的検証は非常に難しいです。

砂の粒度、砂の質量、砂の摩擦係数、クビレの角度、ガラスの摩擦係数などの微妙なバランスで、砂の落下時間はほぼ一定になっています。
これはあくまでも、1Gの環境で一定の時間になっているだけで、重力加速度に変化があった場合には、狂いが生じます。
ただその狂いは、上記の様々な要因により、どちらへ狂うかは個々に違いが出てきます。

説明は非常に難しいのですが、たとえば逆さにしただけで自然に出てくる、調味料入れに入った「砂糖」でも「塩」でもいいですので用意してもらい、その調味料入れの底に紐をつけて、出口が外側を向くようにブンブン振り回すと、回転が遅い間は中の調味料は、回転速度に比例して出方が多くなります。
しかし、ある程度の回転数を超えると(高回転になると)、だんだんと出方が少なくなり、そして突然調味料が出なくなります。

逆さにするだけで出ていた調味料が、重力(上記の場合は遠心力ですが)を徐々に大きくすることで、あるところでピークとなり、それ以上では逆に出なくなる。
これが「ゲート理論」(・・・と言う名前だったと思います。)です。

「液体」にはなく、「粒子」に起こる現象です。

パチンコをされる方であれば、上の皿の大量の玉が、打たれる前の1列の通路の手前で「ダンゴ状態」になる経験があると思います。
そして非常時に、非常出口へ殺到して「ダンゴ状態」になる客もそうです。

これはすべて上述した要因で結果が変わりますので、重力が小さい方が出易い砂時計もあるだろうし、逆に重力が大きい方が非常に出易い砂時計だってあるかも知れません。
一概には言えません。

ただ、統計的に見れば、どちらかへ大きく偏っているかも知れません。形状的な特性で、必ずどちらかになるかも知れません。
しかし「ゲート理論」は複雑で、数字で結果を正確に出すのは困難と思われます。

したがって、「不明」が正解かと思います。

結論としては、砂時計の“形状”などにより、早くもなり遅くもなります。

「砂時計」はご存知の通り、地球上の1Gの環境で、一定の時間に落ちるように砂の量を調整して封入されています。
そして砂時計の“クビレ”の部分を通る砂は、「ゲート理論(?)」により、“抵抗”が与えられています。
その部分の力学的検証は非常に難しいです。

砂の粒度、砂の質量、砂の摩擦係数、クビレの角度、ガラスの摩擦係数などの微妙なバランスで、砂の落下時間はほぼ一定になっています。
これはあくまでも、1Gの環境で...続きを読む

QRst.FindFirst "名称コード" & "=" & "'101'"

タイトルのコードでは問題ないのですが、 101 を文字変数にすると「抽出条件でデータ型が一致していません」のエラーになります。この場合シングルクオーテーションはどういう意味なのでしょうか。
どうすれば良いのでしょうか。

dim Vcode as string
Vcode = "101"
Rst.FindFirst "名称コード" & "=" & Vcode

Aベストアンサー

FindFirst や、フォームの Filter プロパティで設定する場合は、SQL文のWHERE句の
内容を設定する必要があります。

フィールド名がテキスト型の場合は、

SELECT * FROM テーブル名 WHERE フィールド名 = "xxx"

のようになります。
で、FindFirst メソッドなんかで使う場合は、

rst.FindFirst フィールド名 = "xxx"

としたいところですが、条件の部分は文字列にしないといけません。
で、

rst.FindFirst "フィールド名 = "xxx""

こうすると、

フィールド名 =

で、切れてしまいます。
そこで、

rst.FindFirst "フィールド名 = 'xxx'"

このようにすればOKです。
次のステップとして、xxx の部分を変数を使ってやりたい場合。
単純に変数名に置き換えると、

rst.FindFirst "フィールド名 = '変数名'"

ですが、変数を、"" の中に記述すると、文字列として扱われますので、"" の外に
出してやる必要があります。
その場合、文字列と変数をつなぐためには、& を使います。

rst.FindFirst "フィールド名 = '" & 変数名 & "'"

で、このようになります。

FindFirst や、フォームの Filter プロパティで設定する場合は、SQL文のWHERE句の
内容を設定する必要があります。

フィールド名がテキスト型の場合は、

SELECT * FROM テーブル名 WHERE フィールド名 = "xxx"

のようになります。
で、FindFirst メソッドなんかで使う場合は、

rst.FindFirst フィールド名 = "xxx"

としたいところですが、条件の部分は文字列にしないといけません。
で、

rst.FindFirst "フィールド名 = "xxx""

こうすると、

フィールド名 =

で、切れてしまいます...続きを読む

Qもし、一生の時間を刻む砂時計があったら?

もし、一生の時間を刻む砂時計があったら?

寿命センターでは、皆さんの一生を刻む砂時計を管理しています。
要するに、生まれた瞬間から上から下に砂が落ち始め、砂の落ち切った時に一生を終えます。
普通の砂時計はひっくり返すことができますが、これはできません。
また、どんなに揺らしても砂の落ちる量が変わることはありませんし、ガラスが割れることもありません。
どんなことをしても、淡々と砂が落ちていくだけです。

寿命センターでは、希望者本人にこの砂時計を配っています。
もし、こんな砂時計があったら、もらってきますか?

Aベストアンサー

貰ってみたいですね。

自分の目で寿命を実感したら、もう少し1日1日を大切に丁寧に生きられるような気がします。

QShape画像保存モードの事後変更

VBA Excel2007を使用しています。

画像を読み込むために、例えば、

Dim picture As Shape

Set picture = ActiveSheet.Shapes.AddPicture(filename:=filename, LinkToFile:=msoTrue, SaveWithDocument:=msoFalse, Left:=Selection.Left, Top:=Selection.Top, Width:=0, Height:=0)

のように、一旦、画像を「文書とともに保存しない」モードで読込み、後にそのShape画像を「文書とともに保存する」ように変更することは、可能でしょうか。

Aベストアンサー

#1です。Width:=0, Height:=0のため、サイズの無い画像がコピペされているのでは?
下記では如何でしょうか。
Sub test()
Dim myPicture As Shape
Dim myfileName As String

myfileName = "C:\Users\????\Desktop\hoge.jpg"
Set myPicture = ActiveSheet.Shapes.AddPicture(fileName:=myfileName, LinkToFile:=msoTrue, SaveWithDocument:=msoFalse, Left:=Selection.Left, Top:=Selection.Top, Width:=0, Height:=0)
With myPicture
.ScaleHeight 1, msoTrue, msoScaleFromTopLeft
.ScaleWidth 1, msoTrue, msoScaleFromTopLeft
.Cut
End With
ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
End Sub

#1です。Width:=0, Height:=0のため、サイズの無い画像がコピペされているのでは?
下記では如何でしょうか。
Sub test()
Dim myPicture As Shape
Dim myfileName As String

myfileName = "C:\Users\????\Desktop\hoge.jpg"
Set myPicture = ActiveSheet.Shapes.AddPicture(fileName:=myfileName, LinkToFile:=msoTrue, SaveWithDocument:=msoFalse, Left:=Selection.Left, Top:=Selection.Top, Width:=0, Height:=0)
With myPicture
.ScaleHeight 1, msoTrue, msoScaleFromTopLeft
.ScaleWi...続きを読む

Q食卓塩&砂時計の砂の粒子は何メッシュ?

食卓塩&砂時計の砂の粒子は何メッシュくらいでしょうか。お教えください。

Aベストアンサー

No.2です。
前回の書き込みは「アドバイス」にチェックを入れてますし、回答ではありません。
ちょっと遠まわし、かつわかりにくい文章であったのをお詫びします。なので今回は遠まわしにせずにストレートに書きますのでご了承ください。

的確な回答を求めるのであれば「砂時計の砂の粒子」ではなく具体的な説明(大きさや砂時計の時間など)が必要だと思います。

前回のアドバイス中にも書きましたが、
「砂時計のくびれた部分の穴の大きさは、粒径の6倍以上」
なのでくびれた部分の直径がわかれば中の粒子はおよそ1/6ということでおおよそのメッシュ数がわかりますよね。

具体的な記述がなかったためこのような回答しかできませんでした。

QExcel VBA 処理後データが重たくなる&処理スピードが遅いのを解決したい

以前にも質問しそこで回答を頂いた者です。

■VBAで実施したかったこと
一つのExcelファイルでマクロを実行すると、
その並列に並んでいるExcelファイルの中の欄外を一括削除するツール。
※細かい条件は添付ファイルをご参照

■課題
以下、VBAに詳しい教えてgooの詳しい方に教えて頂いたのですが、
二つ問題が起こっていて困っております。

①処理スピードが遅い(1ファイルあたり約10秒。100ファイルあるので、少しでも早いとうれしい)
②処理後、ファイルの容量が重たくなる(1ファイルで、100KBが10MBに膨れ上がる)

■御教示頂きたい事
以下VBAをどのように修正すれば、上記二つの課題をクリアできるでしょうか。
処理スピードが遅いのは最悪なんとかなるのですが、ファイル容量が重たくなるのはできれば避けたいと思っています。宜しくお願いします。

■ VBA
Sub Sample()
Dim 名 As String
ChDir ThisWorkbook.Path
名 = Dir(ThisWorkbook.Path & "\*.*")
Do While 名 <> ""
If LCase$(Right$(名, 5)) = ".xlsx" Then
If LCase$(名) <> LCase$(ThisWorkbook.Name) Then
Workbooks.Open Filename:=名
Range(Cells(1, 4), Cells(Rows.Count, Columns.Count)).Delete
Range(Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1), Cells(Rows.Count, Columns.Count)).Delete
ActiveWorkbook.Save
ActiveWindow.Close
End If
End If
名 = Dir()
Loop
End Sub

以前にも質問しそこで回答を頂いた者です。

■VBAで実施したかったこと
一つのExcelファイルでマクロを実行すると、
その並列に並んでいるExcelファイルの中の欄外を一括削除するツール。
※細かい条件は添付ファイルをご参照

■課題
以下、VBAに詳しい教えてgooの詳しい方に教えて頂いたのですが、
二つ問題が起こっていて困っております。

①処理スピードが遅い(1ファイルあたり約10秒。100ファイルあるので、少しでも早いとうれしい)
②処理後、ファイルの容量が重たくなる(1ファイルで、100KB...続きを読む

Aベストアンサー

こちらの事情で、返事を待つ前に、こちらが考えたものを先に公開しておきます。

※ご質問の画像のようなデータで、「CurrentRegion」 で範囲が取れるという前提にしました。A1セルに対して、CurrentRegion で取れない場合は、以下のマクロはお使いにならないでください。(添付画像)

右端に関しては、、キメウチで、4列目を含め削除するということにしました。

最初に配列のファイル名を入れるというのは、単に私の書き方です。
また、あえて、ブックと処理するフォルダーが同一でなくてもよいと思います。
処理をしたものだけが、上書きされます。
記録を残すようにしました。Debug.Print が不要でしたら、コメントアウトや削除してよいです。


このロジックは、Excelの最終セルをジャンプで探し、データ範囲と比較して、斜め上まで、「削除(Delete)」ではなく「消去(Clear)」を使っています。したがって、OLEオブジェクトがあれば、削除できません。

'//
Sub CleaningExcelSheets()
 Dim Fname, MyPath
 Dim myArray
 Dim i As Long
 Dim LastCell As Range
 ''拡張子が違っても、同名ファイルがないこと
 ReDim myArray(2000)
 MyPath = ThisWorkbook.Path & "\" '末尾には¥が必要
 Fname = Dir(MyPath & "*.xlsx", vbNormal)
 Do While Fname <> ""
  If (GetAttr(MyPath & Fname) And vbNormal) = vbNormal Then
   i = i + 1
   myArray(i) = Fname
   If i > 2000 Then Exit Sub
  End If
  Fname = Dir
 Loop
 '以下ブックの処理
 ReDim Preserve myArray(i)
 Dim rw As Long, cl As Long
 Dim LRw As Long, LCl As Long
 Dim cRng As Range
 Application.ScreenUpdating = False
 For i = 1 To UBound(myArray)
  With Workbooks.Open(MyPath & myArray(i))
   With .ActiveSheet
    If Application.CountA(.Cells) > 0 Then
     
     'CurrentRegionで範囲を取る
     Set cRng = .Range("A1").CurrentRegion
     
     '最下行の次
     rw = cRng(cRng.Count).Row + 1
     '最右列の次 ->D列以降
     ''cl = cRng(cRng.Count).Column + 1
      cl = 4
      
     '最後のセル
     Set LastCell = .Cells.SpecialCells(xlCellTypeLastCell)
     LRw = LastCell.Row
     LCl = LastCell.Column
          
     If LRw >= rw Then
      .Range(.Cells(rw, 1), LastCell).Clear
     End If
     
     If LCl >= cl Then
      .Range(.Cells(1, cl), LastCell).Clear
     End If
   
    End If
   End With
   If .Saved = False Then
    .Save
     Debug.Print "s" & ActiveWorkbook.Name
   Else
     Debug.Print "n" & ActiveWorkbook.Name
   End If
   .Close False
  End With
 Next
 Application.ScreenUpdating = True
 MsgBox "Finish!"
End Sub
'//
もしも、実行する場合は、メイン(消去)になるところは、なるべく理解した上で、行ってください。添付画像は、Range("A1").CurrentRegion.Select

こちらの事情で、返事を待つ前に、こちらが考えたものを先に公開しておきます。

※ご質問の画像のようなデータで、「CurrentRegion」 で範囲が取れるという前提にしました。A1セルに対して、CurrentRegion で取れない場合は、以下のマクロはお使いにならないでください。(添付画像)

右端に関しては、、キメウチで、4列目を含め削除するということにしました。

最初に配列のファイル名を入れるというのは、単に私の書き方です。
また、あえて、ブックと処理するフォルダーが同一でなくてもよいと思います。
処理...続きを読む


人気Q&Aランキング

おすすめ情報