Excel VBA質問箱 IV

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

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


2889 / 13644 ツリー ←次へ | 前へ→

【65423】For〜文の入れ子につきまして murasaki 10/5/19(水) 23:28 質問[未読]
【65425】Re:For〜文の入れ子につきまして kanabun 10/5/20(木) 1:56 発言[未読]
【65427】Re:For〜文の入れ子につきまして murasaki 10/5/20(木) 10:38 お礼[未読]

【65423】For〜文の入れ子につきまして
質問  murasaki  - 10/5/19(水) 23:28 -

引用なし
パスワード
   初心者ですが、お教えいただけないでしょうか。
マクロの勉強しがてら、公開されているマクロを切り貼りして、
目的を達しようとしていましたが、ついに行き詰まってしまいました。

 特定のセルをクリックしてマクロを走らせると、アクティブセルが
特定範囲に入っているか判断したうえで、指定のセル範囲にオートシェイプの
×印(斜線を二つ描)が描かれるマクロを作りたいと考えております。

 特定セルは、行番号s = 5, 18, 31, 44(=5 + 13 * i)で、
列番号t = 3, 8, 13, 18, 23, 28, 33, 38, 43, 48, 53, 58, 63(=3 + 5 * d)
の組み合わせで、計52個あります。
特定セル(計52個)から指定セルまでは等間隔です。

下記(*)のようなマクロを組んでみましたが、
For ループの処理が、先に書かれている行(縦)方向のセルにしか作動しません。
それを
For d = 0 To 12
   t = 3 + 5 * d
    For i = 0 To 3
       s = 5 + 13 *
というふうに書きかえると、今度は列(横)方向のセルにしか作動(×描画)しなくなりました。

 同じ形態で、丸印描かせるマクロ(AddLineではなくAddShape)は、行方向、列方向にも正常に動いています。

 なにがおかしいのか、どうすればCells(s,t)に変数が代入できるかお教えいただけないでしょうか。
どうぞよろしくお願いいたします。

*)

Sub バツ()
 Dim i As Integer, d As Integer, s As Integer, t As Integer
 Dim xa As Double, ya As Double, Endxa As Double, EndYa As Double, xb As Double, yb As Double, Endxb As Double, EndYb As Double
 Dim p As Variant, g As Variant

  For i = 0 To 3
    s = 5 + 13 * i
     For d = 0 To 12
        t = 3 + 5 * d
  
  Set p = Cells(s, t)
  Set g = Intersect(ActiveCell, p)

If Not g Is Nothing Then
  With Cells(s + 4, t)
   xa = .Left
   ya = .Top
  End With

  With Cells(s + 8, t)
   xb = .Left
   yb = .Top
  End With

  With Cells(s + 7, t + 4)
   Endxa = .Left + .Width
   EndYa = .Top + .Height
  End With

 With Cells(s + 3, t + 4)
   Endxb = .Left + .Width
   EndYb = .Top + .Height
 End With

  Dim ShpN(1 To 2) As Variant
   Set Shp1 = ActiveSheet.Shapes.AddLine(xa, ya, Endxa, EndYa)
   Set Shp2 = ActiveSheet.Shapes.AddLine(xb, yb, Endxb, EndYb)
      ShpN(1) = Shp1.Name
      ShpN(2) = Shp2.Name
        ActiveSheet.Shapes.Range(ShpN(1)).Fill.Visible = msoFalse
        ActiveSheet.Shapes.Range(ShpN(2)).Fill.Visible = msoFalse
        ActiveSheet.Shapes.Range(ShpN(1)).ZOrder msoBringToFront
        ActiveSheet.Shapes.Range(ShpN(2)).ZOrder msoBringToFront
        ActiveSheet.Shapes.Range(ShpN(1)).Line.Weight = 0.55
        ActiveSheet.Shapes.Range(ShpN(2)).Line.Weight = 0.55
        ActiveSheet.Shapes.Range(ShpN).Group.Select

   Set g = Nothing
 Else
    Exit For

End If

    Next d
  Next i

End Sub

【65425】Re:For〜文の入れ子につきまして
発言  kanabun  - 10/5/20(木) 1:56 -

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


> 特定のセルをクリックしてマクロを走らせると、アクティブセルが
>特定範囲に入っているか判断したうえで、指定のセル範囲にオートシェイプの
>×印(斜線を二つ描)が描かれるマクロを作りたいと考えております。
>
> 特定セルは、行番号s = 5, 18, 31, 44(=5 + 13 * i)で、
>列番号t = 3, 8, 13, 18, 23, 28, 33, 38, 43, 48, 53, 58, 63(=3 + 5 * d)
>の組み合わせで、計52個あります。
>特定セル(計52個)から指定セルまでは等間隔です。
>

>For ループの処理が、先に書かれている行(縦)方向のセルにしか作動しません。

ざっと見た感じでは、

>  Else
>     Exit For
の位置がおかしいように思います。
 Else
   Exit For
でなく、

 If アクティブセルが指定のセルにあったら、
   バツを描画して
   For〜Nextループを抜ける(Exit)
 End If

ということではないかと?
それであれば、

>  Set g = Intersect(ActiveCell, p)
>  If Not g Is Nothing Then
     描画処理
     Exit Sub
>  End If

で、描画したら、さっさと終了してしまっても良さそうな気がします。

あと、Loopカウンタは Step を使って 以下のように
書けます。

Sub バツ2()
 Dim s As Long, t As Long
 Dim X As Range, g As Range
 Dim ShpN(1 To 2) As Variant

 For s = 5 To 44 Step 13
   For t = 3 To 63 Step 5

     Set g = Intersect(ActiveCell, Cells(s, t))
     
     If Not g Is Nothing Then
       Set X = ActiveCell.Offset(4).Resize(4, 5)
       
       With ActiveSheet.Shapes.AddLine( _
        X.Left, X.Top, X.Left + X.Width, X.Top + X.Height)
         .Fill.Visible = msoFalse
         .ZOrder msoBringToFront
         .Line.Weight = 0.55
         ShpN(1) = .Name
       End With
       
       With ActiveSheet.Shapes.AddLine( _
        X.Left + X.Width, X.Top, X.Left, X.Top + X.Height)
         .Fill.Visible = msoFalse
         .ZOrder msoBringToFront
         .Line.Weight = 0.55
         ShpN(2) = .Name
       End With
       ActiveSheet.Shapes.Range(ShpN).Group
       Exit Sub
     
     End If
   Next t
 Next s

End Sub

【65427】Re:For〜文の入れ子につきまして
お礼  murasaki  - 10/5/20(木) 10:38 -

引用なし
パスワード
    ありがとうございます!
思い通りに動きました。
 こんなにシンプルできれいになるんなんて感動です。
取り急ぎ御礼まで、失礼いたします。

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