Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(指定なし : 指定なし)
記述の簡素化
投稿日時: 17/08/02 11:26:37
投稿者: hisayanxp

いつもありがとうございます。
よろしくお願いします。
  
B10からD2まで1つ1つセルを選択しながら移動する記述をやってみたのですが、記述が同じことの繰り返しが多いのでなんとかそうした部分を簡素化できる方法がないかと思い質問いたしました。
 
Sub Trace4()
    Range("B10").Activate
    Range("B10").Interior.Color = vbRed
                Application.Wait Now + TimeValue("0:0:01")
    Range("B9").Activate
    Range("B10").ClearFormats
    Range("B9").Interior.Color = vbRed
                Application.Wait Now + TimeValue("0:0:01")
    Range("B8").Activate
    Range("B9").ClearFormats
    Range("B8").Interior.Color = vbRed
                Application.Wait Now + TimeValue("0:0:01")
    Range("B7").Activate
    Range("B8").ClearFormats
    Range("B7").Interior.Color = vbRed
                Application.Wait Now + TimeValue("0:0:01")
    Range("B6").Activate
    Range("B7").ClearFormats
    Range("B6").Interior.Color = vbRed
                Application.Wait Now + TimeValue("0:0:01")
    Range("B5").Activate
    Range("B6").ClearFormats
    Range("B5").Interior.Color = vbRed
                Application.Wait Now + TimeValue("0:0:01")
    Range("B4").Activate
    Range("B5").ClearFormats
    Range("B4").Interior.Color = vbRed
                Application.Wait Now + TimeValue("0:0:01")
    Range("B3").Activate
    Range("B4").ClearFormats
    Range("B3").Interior.Color = vbRed
                Application.Wait Now + TimeValue("0:0:01")
    Range("B2").Activate
    Range("B3").ClearFormats
    Range("B2").Interior.Color = vbRed
                Application.Wait Now + TimeValue("0:0:01")
    Range("C2").Activate
    Range("B2").ClearFormats
    Range("C2").Interior.Color = vbRed
                Application.Wait Now + TimeValue("0:0:01")
    Range("D2").Activate
    Range("C2").ClearFormats
    Range("D2").Interior.Color = vbRed
                Application.Wait Now + TimeValue("0:0:01")
End Sub

回答
投稿日時: 17/08/02 12:47:18
投稿者: 半平太

こんなので、同じ様なことになりそう。

Sub Trace4()
    Dim cel As Range
    Dim RW As Long, CL As Long
    
    Set cel = Cells(10, "B")
    cel.Interior.Color = vbRed
    
    For RW = 9 To 2 Step -1
        Application.Wait Now + TimeValue("0:0:01")
        cel.ClearFormats
        Set cel = Cells(RW, "B")
        cel.Interior.Color = vbRed
    Next RW
    
    For CL = 3 To 4
        Application.Wait Now + TimeValue("0:0:01")
        cel.ClearFormats
        Set cel = Cells(2, CL)
        Cells(2, CL).Interior.Color = vbRed
    Next CL
End Sub

回答
投稿日時: 17/08/02 13:17:59
投稿者: Suzu

移動するセルが縦から横に途中で変わっているので
RowとColumn で 続けて移動させるのは好みでは無いので
移動先を初めから登録してしまいました。
 
Sub CellStatusBar()
    Dim varAddress As Variant
    Dim strAddress As String
    Dim i As Integer
 
    strAddress = "B10,B9,B8,B7,B6,B5,B4,B3,B2,C2,D2"
    varAddress = Split(strAddress, ",", -1, vbTextCompare)
 
    Range(strAddress).Interior.Pattern = xlNone
 
    For i = LBound(varAddress) To UBound(varAddress)
        Range(varAddress(i)).Activate
        If i <> 0 Then Range(varAddress(i - 1)).Interior.Pattern = xlNone
        Range(varAddress(i)).Interior.Color = vbRed
        Application.Wait Now + TimeValue("0:0:01")
    Next
End Sub

回答
投稿日時: 17/08/03 12:52:43
投稿者: mattuwan44

この質問は、
 
「ある」セル範囲の外周をアニメーションっぽく、
ぐるぐる時計回りに回っているように、見せたいがテーマなのかな?
 
そうだとしたら、人によって色々書けそう^^(いろんなテクニックが見れそう?)
 
その辺、目的が解れば回答者もモチベーションがあがるかも^^
 
何か考えたいけど時間が無い^^;;

回答
投稿日時: 17/08/03 15:58:57
投稿者: kakka

こんにちわ。
この動きだけで良いのか、他の動きもしたいか分からなかったので
一般化出来るようにこんな感じで書いて見ました。
 
Sub Sample()
 
Range("B10").Activate
Range("B10").Interior.Color = vbRed
Application.Wait Now + TimeValue("0:0:01")
 
Call CellMove("U", 8)
Call CellMove("R", 2)
 
MsgBox "Complete"
End Sub
 
Sub CellMove(UDLR As String, l As Long)
Dim i As Long
On Error Resume Next
Select Case UDLR
   Case "U"
      For i = 1 To l
         ActiveCell.Interior.Pattern = xlNone
         ActiveCell.Offset(-1, 0).Activate
         ActiveCell.Interior.Color = vbRed
         Application.Wait Now + TimeValue("0:0:01")
      Next i
   Case "D"
      For i = 1 To l
         ActiveCell.Interior.Pattern = xlNone
         ActiveCell.Offset(1, 0).Activate
         ActiveCell.Interior.Color = vbRed
         Application.Wait Now + TimeValue("0:0:01")
      Next i
   Case "L"
      For i = 1 To l
         ActiveCell.Interior.Pattern = xlNone
         ActiveCell.Offset(0, -1).Activate
         ActiveCell.Interior.Color = vbRed
         Application.Wait Now + TimeValue("0:0:01")
      Next i
   Case "R"
      For i = 1 To l
         ActiveCell.Interior.Pattern = xlNone
         ActiveCell.Offset(0, 1).Activate
         ActiveCell.Interior.Color = vbRed
         Application.Wait Now + TimeValue("0:0:01")
      Next i
   Case Else
      Application.Wait Now + TimeValue("0:0:01")
End Select
On Error GoTo 0
End Sub

回答
投稿日時: 17/08/03 16:08:23
投稿者: kakka

連投失礼します。
簡素化、ということでもっと簡単にかけますね・・・。
 
Sub Sample()
 
Range("B10").Activate
Range("B10").Interior.Color = vbRed
Application.Wait Now + TimeValue("0:0:01")
 
Call CellMove("U", 8)
Call CellMove("R", 2)
 
MsgBox "Complete"
End Sub
 
Sub CellMove(UDLR As String, l As Long)
Dim i As Long
On Error Resume Next
 
For i = 1 To l
   ActiveCell.Interior.Pattern = xlNone
   Select Case UDLR
      Case "U"
         ActiveCell.Offset(-1, 0).Activate
      Case "D"
         ActiveCell.Offset(1, 0).Activate
      Case "L"
         ActiveCell.Offset(0, -1).Activate
      Case "R"
         ActiveCell.Offset(0, 1).Activate
   End Select
   ActiveCell.Interior.Color = vbRed
   Application.Wait Now + TimeValue("0:0:01")
Next i
 
On Error GoTo 0
End Sub

回答
投稿日時: 17/08/03 16:46:10
投稿者: hatena
投稿者のウェブサイトに移動

kakkaさんのを元に、さらに汎用化をすすめてみました。
 

Sub Sample()

    Call CellMove(Range("B10"), -1, 0, 8)
    Call CellMove(ActiveCell, 0, 1, 2)

    MsgBox "Complete"
End Sub

'目的: アクティブセルを移動
'引数: SCell 開始位置のセル
'      VMove 垂直移動量
'      HMove 水平移動量
'      RepCount 繰り返し回数
'      Interval 繰り返し間隔(秒)省略可 既定値 1
'      BColor 背景色 省略可 既定値 赤
Public Sub CellMove(SCell As Range, VMove As Long, HMove As Long, RepCount As Long, _
                    Optional Interval As Long = 1, Optional BColor As Long = vbRed)
    Dim i As Long
    On Error Resume Next
    SCell.Activate
    SCell.Interior.Color = BColor
    For i = 1 To RepCount
        ActiveCell.Interior.Pattern = xlNone
        ActiveCell.Offset(VMove, HMove).Activate
        ActiveCell.Interior.Color = BColor
        Application.Wait Now + TimeSerial(0, 0, Interval)
    Next
End Sub

投稿日時: 17/08/04 07:04:15
投稿者: hisayanxp

みなさん、ありがとうございます。
ご指摘のあったようにアニメーション化ができたら思しろいなぁということで質問させていただきました。
今みなさんからいただいた記述の内容を考えながら1つ1つ試しています。
全部終わりましたらまたご報告します。

回答
投稿日時: 17/08/07 10:59:39
投稿者: mattuwan44

ども^^
 
セル数が多くなると使えないですけど、
これが簡単ですかね?
 
Sub test()
    Dim Rng As Range
    Dim c As Range
 
    Set Rng = Range("B10,B9,B8,B7,B6,B5,B4,B3,B2,C2:D2")
    For Each c In Rng
        Rng.Interior.ColorIndex = xlNone
        With c
            .Interior.Color = vbRed
            Application.Wait Now + TimeValue("0:0:01")
        End With
    Next
End Sub
 
行や列のインデックス番号を操作して、時計みたいにグルグル回るように作りたいけど、
やってみると、なかなかめんどくさいですねぇ。。。

回答
投稿日時: 17/08/08 21:27:59
投稿者: MMYS

mattuwan44 さんの引用:

時計みたいにグルグル回るように作りたいけど、
やってみると、なかなかめんどくさいですねぇ。。。

ぐるっと一周するコード書いてみました。
 
Sub test()
    Dim startR  As Integer
    Dim startC  As Integer
    Dim endR    As Integer
    Dim endC    As Integer
    Dim moveR   As Integer
    Dim moveC   As Integer
    Dim r   As Integer
    Dim c   As Integer

    With Range("B2:D10")
        startR = .Row
        startC = .Column
        endR = .Rows.Count + (startR - 1)
        endC = .Columns.Count + (startC - 1)
    End With

    r = startR
    c = startC
    Do
        Cells(r, c).Activate
        With Cells(r, c).Interior
            .Color = vbRed
            Application.Wait Now + TimeValue("0:0:01")
            .ColorIndex = xlNone
        End With
        
        moveC = 0
        If (r = startR) And (c < endC) Then moveC = 1
        If (r = endR) And (startC < c) Then moveC = -1
        moveR = 0
        If (c = endC) And (r < endR) Then moveR = 1
        If (c = startC) And (startR < r) Then moveR = -1
                
        c = c + moveC
        r = r + moveR        
    Loop Until (r = startR) And (c = startC)

End Sub

回答
投稿日時: 17/08/08 21:43:16
投稿者: MMYS

上記のコード。一周するだけじゃつまらないので
ルーレットもどきにしてみました。
 

Sub Roulette()
    Dim startR  As Integer
    Dim startC  As Integer
    Dim endR    As Integer
    Dim endC    As Integer
    Dim moveR   As Integer
    Dim moveC   As Integer
    Dim r   As Integer
    Dim c   As Integer
    Dim i   As Integer
    Dim qty As Integer

    Randomize
    qty = Rnd() * 40 + 20
    Debug.Print qty

    With Range("B2:E5")
        startR = .Row
        startC = .Column
        endR = .Rows.Count + (startR - 1)
        endC = .Columns.Count + (startC - 1)
        .Interior.ColorIndex = 15
    End With

    r = startR
    c = startC
    For i = 0 To qty
        Cells(r, c).Activate
        With Cells(r, c).Interior
            .ColorIndex = 3
            Beep
            WaitSleep i / 100
            .ColorIndex = xlNone
        End With
        
        moveC = 0
        If (r = startR) And (c < endC) Then moveC = 1
        If (r = endR) And (startC < c) Then moveC = -1
        moveR = 0
        If (c = endC) And (r < endR) Then moveR = 1
        If (c = startC) And (startR < r) Then moveR = -1
                
        c = c + moveC
        r = r + moveR
    Next

End Sub

Sub WaitSleep(waitTime As Single)
    Dim nextTime As Single
     nextTime = Timer + waitTime
     Do Until Timer > nextTime
         DoEvents
     Loop
End Sub

[/code]

投稿日時: 17/08/12 11:28:30
投稿者: hisayanxp

皆さん、ありがとうございました。
今現在の私の知識では完璧に理解できたのは半平太さんの記述だけでした。
継続して他の記述も研究してゆきます。
中途半端なまま「解答受付中」にしておくのは不本意ですので「解決済み」とさせていただきます。
ありがとうございました。