Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


2585 / 13645 ツリー ←次へ | 前へ→

【67065】Application.ScreenUpdatingについての質問です。 かなたん 10/10/30(土) 2:21 質問[未読]
【67069】Re:Application.ScreenUpdatingについての... SK63 10/10/30(土) 12:11 発言[未読]
【67072】Re:Application.ScreenUpdatingについての... かなたん 10/10/30(土) 12:28 回答[未読]
【67070】Re:Application.ScreenUpdatingについての... かなたん 10/10/30(土) 12:19 発言[未読]
【67071】Re:Application.ScreenUpdatingについての... SK63 10/10/30(土) 12:23 発言[未読]
【67073】Re:Application.ScreenUpdatingについての... かなたん 10/10/30(土) 12:33 回答[未読]
【67074】Re:Application.ScreenUpdatingについての... SK63 10/10/30(土) 12:50 回答[未読]
【67075】Re:Application.ScreenUpdatingについての... かなたん 10/10/30(土) 13:12 お礼[未読]
【67076】Re:Application.ScreenUpdatingについての... SK63 10/10/30(土) 16:34 発言[未読]

【67065】Application.ScreenUpdatingについての質...
質問  かなたん  - 10/10/30(土) 2:21 -

引用なし
パスワード
   みなさん初めまして。
Windows7にてExcel2007を使ってVBAでプログラミングをしているかなたんといいます。
まずは、リバーシのプログラムを組んでいたときの話です。
(初めに書いておきます。 これは半分前置きのような話です。)
対戦が終わった最後、どちらが勝ったのかを比べるために以下の方法をとりました。
----------------------------------------------------------------------
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub 判定()
  MsgBox "どっちが勝ったか比べてみましょう。", vbOKOnly, "リバーシ"
  Dim Bc As Byte, Bm As Byte, Bi As Byte, Bb As Boolean, Wc As Byte, Wm As Byte, Wi As Byte, Wb As Boolean
    Bc = 1
    Bb = True
    Wc = 1
    Wb = True
  For R = 1 To 8 '盤面のこまをすべて緑に変える。
    For C = 1 To 8
      ActiveSheet.Shapes("N" & R & "_" & C).Select
      Selection.ShapeRange.Line.ForeColor.SchemeColor = 17
      Selection.ShapeRange.Fill.ForeColor.SchemeColor = 17
    Next
  Next '1.
  MsgBox "どっちが勝ったのでしょう?", vbOKOnly, "リバーシ"
Again:
  Sleep 100
  If Bc <= Range("K5") Then '黒が取ったこまの数だけ行う
    Bm = Bc Mod 8
    If Bm = 0 Then
      Bm = 8
      Bi = Int(Bc / 8)
    Else
      Bi = Int(Bc / 8) + 1
    End If
    ActiveSheet.Shapes("N" & Bi & "_" & Bm).Select
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 8
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = 8 '2.
    Bc = Bc + 1
  Else
    Bb = False 'もう黒のこまはないと言う
  End If
  If Wc <= Range("K7") Then '白がとったこまの数だけ行う
    Wm = Wc Mod 8
    If Wm = 0 Then
      Wm = 1
      Wi = (9 - Int(Wc / 8))
    Else
      Wm = (9 - Wm)
      Wi = (9 - (Int(Wc / 8) + 1))
    End If
    ActiveSheet.Shapes("N" & Wi & "_" & Wm).Select
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 8
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = 9 '3.
    Wc = Wc + 1
  Else
    Wb = False 'もう白のこまはないと言う
  End If
  If Bb = True Or Wb = True Then 'もしどちらかのこまがあれば
    GoTo Again 'Againに戻ってもう一度行う
  End If
  Application.Run "勝ち.勝ち"
End Sub
----------------------------------------------------------------------
すると、盤面を緑に変える前(あるいはその動作が飛ばされたあと?)に2のメッセージボックスが出てきてしまい、黒と白のこまを並べる部分では、カーソルが変わって処理中なのはわかるのですが、盤面が変わらずに4のメッセージボックスが出てきてしまいました。
そこで、このコードの先頭(Subの次の行)に
Application.ScreenUpdating = True
と書いてみたのですが、それでも盤面が変わらずにメッセージボックスが出てくるだけでした。
なので、1.2.3.のあとに↑のコードを書いたところ、今度は盤面が変わってからメッセージボックスが出るようになりました。
そのときは、「VBAが画面の更新をサボったんだなぁ」と勝手に思っていました。

今神経衰弱を作ろうと思っていて、このApplication.ScreenUpdatingであれ?っと思ったことがあるので質問させてください。
(今回はこちらが本題です。)
シャッフルを次の方法でさせています。
-----------------------------------------------------------------------
Sub 切る()
  Application.ScreenUpdating = False
  Dim T As Byte, i(3) As Byte
  Dim Memo(1 To 52), Mark(3) As String, JQ(11 To 12) As String
    Mark(0) = "ダイヤ"
    Mark(1) = "ハート"
    Mark(2) = "スペード"
    Mark(3) = "クラブ"
    JQ(11) = "J"
    JQ(12) = "Q"
  Dim R As Byte, C As Byte
  Randomize
  i(0) = Int(52 * Rnd) + 1 '最初の数字を選ぶ
  i(1) = Int(i(0) / 13)
  i(2) = i(0) Mod 13
  If i(2) = 0 Then '選ばれた数字によって配置するカードを決める
    Memo(1) = Mark(i(1) - 1) & "のK"
    Worksheets(1).Cells(2, 2) = Mark(i(1) - 1) & "のK"
    Worksheets(1).Cells(3, 2) = "K"
  ElseIf i(2) >= 11 Then
    Memo(1) = Mark(i(1)) & "の" & JQ(i(2))
    Worksheets(1).Cells(2, 2) = Mark(i(1)) & "の" & JQ(i(2))
    Worksheets(1).Cells(3, 2) = JQ(i(2))
  Else
    Memo(1) = Mark(i(1)) & "の" & i(2)
    Worksheets(1).Cells(2, 2) = Mark(i(1)) & "の" & i(2)
    Worksheets(1).Cells(3, 2) = i(2)
  End If
  Application.ScreenUpdating = False
  Worksheets(1).Shapes(Memo(1)).Top = 67.5 '決められたカードの位置を変更する
  Worksheets(1).Shapes(Memo(1)).Left = 45
  Application.ScreenUpdating = False
  For T = 2 To 52 '上と同じようなことを繰り返す
Again:
    i(0) = Int(52 * Rnd) + 1
    i(1) = Int(i(0) / 13)
    i(2) = i(0) Mod 13
    If i(2) = 0 Then
      Memo(T) = Mark(i(1) - 1) & "のK"
    ElseIf i(2) >= 11 Then
      Memo(T) = Mark(i(1)) & "の" & JQ(i(2))
    Else
      Memo(T) = Mark(i(1)) & "の" & i(2)
    End If
    For i(0) = 1 To (T - 1)
      If Memo(T) = Memo(i(0)) Then 'もし今選んだカードが一度選ばれていたならば
        GoTo Again 'Againに戻ってもう一度選びなおす
      End If
    Next
    If (T Mod 13 = 0) Then
      R = 2 * Int(T / 13)
      C = 50
    Else
      R = 2 * Int(T / 13) + 2
      C = (4 * (T Mod 13) - 3) + 1
    End If
    If i(2) = 0 Then
      Worksheets(1).Cells(R, C) = Mark(i(1) - 1) & "のK"
      Worksheets(1).Cells((R + 1), C) = "K"
    ElseIf i(2) >= 11 Then
      Worksheets(1).Cells(R, C) = Mark(i(1)) & "の" & JQ(i(2))
      Worksheets(1).Cells((R + 1), C) = JQ(i(2))
    Else
      Worksheets(1).Cells(R, C) = Mark(i(1)) & "の" & i(2)
      Worksheets(1).Cells((R + 1), C) = i(2)
    End If
    Application.ScreenUpdating = False
    Worksheets(1).Shapes(Memo(T)).Top = 67.5 * (R / 2)
    Worksheets(1).Shapes(Memo(T)).Left = 45 * (Int((C - 2) / 4) + 1)
    Application.ScreenUpdating = False
  Next
  Application.ScreenUpdating = True
End Sub
-----------------------------------------------------------------------
最初は"Application.ScreenUpdating = False"等はどこにも書かずにいたのですが、画面がちらついて背面に配置していたカードの数字が書いてあるものが、カードの絵柄の前にチラッと出てきてしまっているように見えてしまいます。
そこで、次に先頭に"Application.ScreenUpdating = False"を書いたのですが、それでも状況が変わりません。
そこで、ためしに↑のコードのようにカードを移動させる前と移動させたあとにも書き加えたのですが、それでも状況は変わりません。
そこで、最後に"Application.ScreenUpdating = True"を書き加えたのですが、やはりそれでも状況はまったっく変わりません。

"Application.ScreenUpdating = False"は画面の更新を抑制するためのコードだと思っているのですが、なぜ↑のコードでは抑制されないのでしょうか?
私なりにGoogleで調べてみようと思い、検索の候補(?)にあがっていた「application.screenupdating false 効かない」というので調べてみたのですが、いろいろと見てみましたがなぜこのコードでこうなってしまうのかがわかりませんでした。
シャッフルするときにどこに何があるのかが見えてしまわないようにシャッフルさせたいのですが、どのように書き直せばそういうことができるのでしょうか?
どなたか知っている人がいましたら、どうかよろしくお願いいたします。

【67069】Re:Application.ScreenUpdatingについて...
発言  SK63  - 10/10/30(土) 12:11 -

引用なし
パスワード
   こんにちは、現在EXCEL2007を使っていないので(いぜんは使用)
使わなくなった理由グラフ描画が遅く、よく止まっていた。

明確でないのですが、
Worksheets(1).Shapes(Memo(1)).Left = 45
のような、オートシェイプやグラフを使用したときに
動作が遅いとか、動作が停止したりすることがありました。
また、オートシェイプには、Application.ScreenUpdating = False
は有効ではなかった記憶がありますので

Application.ScreenUpdating = False
Worksheets(1).Shapes(Memo(1)).Top = 67.5 '決められたカードの位置を変更する
Worksheets(1).Shapes(Memo(1)).Left = 45
Application.ScreenUpdating = False

この当たりをとりあえずコメントアウトして動作させると確認できると思います。

オートシェイプは目ではエクセル上にありますが重なるように別に構成されています。

【67070】Re:Application.ScreenUpdatingについて...
発言  かなたん  - 10/10/30(土) 12:19 -

引用なし
パスワード
   回答をするときの参考になればと、今作っている神経衰弱のファイルを以下にアップしてみました。

park.geocities.jp/programing_games/Excel/sinkeisuizyaku.xls

右側にあるシャッフルするのボタンをクリックしてみると、質問のような症状が出てしまいます。
(シャッフルする以外のほかの部分はまだ大して出来上がっていないので、試してみてもへんな動作をするかもしれません。)

もちろん回答をせかすつもりはありません。
私も気長に誰かが答えてくださるのを待つつもりです。
それでは。

【67071】Re:Application.ScreenUpdatingについて...
発言  SK63  - 10/10/30(土) 12:23 -

引用なし
パスワード
   ▼かなたん さん:

逃げ道ですが、ハートの9とかのテキストを1度バックカラーと同じにして
処理が終わったときに元に戻すとかでは?(画面更新はの〜はいれずに)

【67072】Re:Application.ScreenUpdatingについて...
回答  かなたん  - 10/10/30(土) 12:28 -

引用なし
パスワード
   ▼SK63 さん:回答ありがとうございます。
>明確でないのですが、
>Worksheets(1).Shapes(Memo(1)).Left = 45
>のような、オートシェイプやグラフを使用したときに
>動作が遅いとか、動作が停止したりすることがありました。

私は動作が遅いとか停止したと感じたことはありませんね。

>また、オートシェイプには、Application.ScreenUpdating = False
>は有効ではなかった記憶がありますので

そうなのですか?
それは知りませんでした・・・

> Application.ScreenUpdating = False
> Worksheets(1).Shapes(Memo(1)).Top = 67.5 '決められたカードの位置を変更する
> Worksheets(1).Shapes(Memo(1)).Left = 45
> Application.ScreenUpdating = False
>
>この当たりをとりあえずコメントアウトして動作させると確認できると思います。
>
>オートシェイプは目ではエクセル上にありますが重なるように別に構成されています。

はい。
そのあたりをコメントアウトしてみても、やはり質問の症状が出てきてしまいますね・・・
ということは、半分あきらめるしかないのでしょうか?

【67073】Re:Application.ScreenUpdatingについて...
回答  かなたん  - 10/10/30(土) 12:33 -

引用なし
パスワード
   ▼SK63 さん:
>逃げ道ですが、ハートの9とかのテキストを1度バックカラーと同じにして
>処理が終わったときに元に戻すとかでは?(画面更新はの〜はいれずに)

数字等が見られないようにを考えると、そうするのがいいですかねぇ?
あっ。
いっそのこと全部
Worksheets(1).Shapes("カードの名前").Visible = False
で見えなくしてからシャッフルさせるというのも使えるかもしれないですね。
では、これから両方とも試してみようと思います。

【67074】Re:Application.ScreenUpdatingについて...
回答  SK63  - 10/10/30(土) 12:50 -

引用なし
パスワード
   ▼かなたん さん:
Application.EnableEvents = False を頭に
Application.EnableEvents = Trueを終わりに入れてください
上手くいきますた。


Sub 切る()

  'Application.ScreenUpdating = False
  Application.EnableEvents = False
  
  Dim T As Byte, i(3) As Byte
  Dim Memo(1 To 52), Mark(3) As String, JQ(11 To 12) As String
    Mark(0) = "ダイヤ"
    Mark(1) = "ハート"
    Mark(2) = "スペード"
    Mark(3) = "クラブ"
    JQ(11) = "J"
    JQ(12) = "Q"
  Dim R As Byte, C As Byte
  Randomize
  i(0) = Int(52 * Rnd) + 1
  i(1) = Int(i(0) / 13)
  i(2) = i(0) Mod 13
  If i(2) = 0 Then
    Memo(1) = Mark(i(1) - 1) & "のK"
    Worksheets(1).Cells(2, 2) = Mark(i(1) - 1) & "のK"
    Worksheets(1).Cells(3, 2) = "K"
  ElseIf i(2) >= 11 Then
    Memo(1) = Mark(i(1)) & "の" & JQ(i(2))
    Worksheets(1).Cells(2, 2) = Mark(i(1)) & "の" & JQ(i(2))
    Worksheets(1).Cells(3, 2) = JQ(i(2))
  Else
    Memo(1) = Mark(i(1)) & "の" & i(2)
    Worksheets(1).Cells(2, 2) = Mark(i(1)) & "の" & i(2)
    Worksheets(1).Cells(3, 2) = i(2)
  End If
 
  Worksheets(1).Shapes(Memo(1)).Top = 67.5
  Worksheets(1).Shapes(Memo(1)).Left = 45
  
  For T = 2 To 52
Again:
    i(0) = Int(52 * Rnd) + 1
    i(1) = Int(i(0) / 13)
    i(2) = i(0) Mod 13
    If i(2) = 0 Then
      Memo(T) = Mark(i(1) - 1) & "のK"
    ElseIf i(2) >= 11 Then
      Memo(T) = Mark(i(1)) & "の" & JQ(i(2))
    Else
      Memo(T) = Mark(i(1)) & "の" & i(2)
    End If
    For i(0) = 1 To (T - 1)
      If Memo(T) = Memo(i(0)) Then
        GoTo Again
      End If
    Next
    If (T Mod 13 = 0) Then
      R = 2 * Int(T / 13)
      C = 50
    Else
      R = 2 * Int(T / 13) + 2
      C = (4 * (T Mod 13) - 3) + 1
    End If
    If i(2) = 0 Then
      Worksheets(1).Cells(R, C) = Mark(i(1) - 1) & "のK"
      Worksheets(1).Cells((R + 1), C) = "K"
    ElseIf i(2) >= 11 Then
      Worksheets(1).Cells(R, C) = Mark(i(1)) & "の" & JQ(i(2))
      Worksheets(1).Cells((R + 1), C) = JQ(i(2))
    Else
      Worksheets(1).Cells(R, C) = Mark(i(1)) & "の" & i(2)
      Worksheets(1).Cells((R + 1), C) = i(2)
    End If
  
    Worksheets(1).Shapes(Memo(T)).Top = 67.5 * (R / 2)
    Worksheets(1).Shapes(Memo(T)).Left = 45 * (Int((C - 2) / 4) + 1)
  Next
 
  Application.EnableEvents = True
 
  ' Application.ScreenUpdating = True
End Sub

【67075】Re:Application.ScreenUpdatingについて...
お礼  かなたん  - 10/10/30(土) 13:12 -

引用なし
パスワード
   ▼SK63 さん:
> Application.EnableEvents = False を頭に
> Application.EnableEvents = Trueを終わりに入れてください
>上手くいきますた。

はい。
"Application.ScreenUpdating = False"等を消して上のものを消してみたらうまく見えない状態で作動してくれました。
どうもありがとうございました。

ちなみに、
Worksheets(1).Shapes("カードの名前").Visible = False
で透明化させる方法は、それでも見えてしまってうまくいきませんでした。
SK63さんが提案された文字の色を一度変えてしまってというのは、
シェイプ内の文字の色をどうやって変えたらよいか調べてみてもわからなかったのであきらめました。
マクロの自動記録も試しましたが、記録してもらえませんでした・・・

【67076】Re:Application.ScreenUpdatingについて...
発言  SK63  - 10/10/30(土) 16:34 -

引用なし
パスワード
   ▼かなたん さん:
>▼SK63 さん:

こんな風に使います。

With ActiveSheet.Shapes.AddShape(msoShapeParallelogram, st, lngTop - (a - lngTop), et - st + 25, a - lngTop + 10)
   .Fill.ForeColor.SchemeColor = 9 '塗りつぶし...白
   .Line.ForeColor.SchemeColor = 64 '枠線...自動
   .DrawingObject.Text = 駆動時間 '位置合わせは、スペースをいれでもよい。
   .DrawingObject.Font.ColorIndex = 1'テキストカラー
End With

2585 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free