Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

4055 / 76734

←次へ　｜　前へ→


	【78307】Re:Randomwalk

カリーニン - 16/6/23(木) 21:23 -


	引用なし

	パスワード

横から失礼します。

面白そうですね。やってることは違いますが、昔似たような？ことをしたことがありますので
参考出品します。
test
の中の
Call main(200)
の数値を変えて試してみてください。

Option Explicit
Public mystop As Boolean
Public r As Range

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Dim saidai As Long
Dim saishou As Long
Dim cnt As Long
Dim NRng As Range
Dim hantei As Boolean
Dim bl As Boolean
Dim prerng As Range
Dim iti As String

Sub test()
Call main(200)
End Sub

Function main(ByVal maxnum As Long)
Dim ws As Worksheet
mystop = True
saidai = 4
saishou = 1
cnt = 1
Set ws = ThisWorkbook.Worksheets(1)
Application.ScreenUpdating = False
ws.Cells.Delete
Application.ScreenUpdating = True
ws.Cells.ColumnWidth = 2.5
ws.Cells(1, 1).Value = cnt
Set r = ws.Cells(1, 1)
bl = False
Do Until bl = True
　If mystop = False Then Exit Do
　bl = False
　Call nextrng
　cnt = cnt + 1
　'**********
　If cnt = 2 Then
　　 Set prerng = ws.Cells(1, 1)
'　　 Set r = prerng
　　 If NRng.Address = prerng.Offset(1).Address Then
　　　　With prerng
　　　　'上
　　　　 With .Borders(xlEdgeTop)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlThin
　　　　.ColorIndex = xlAutomatic
　　　　 End With
　　　　'左
　　　　 With .Borders(xlEdgeLeft)
　　　　 .LineStyle = xlContinuous
　　　　 .Weight = xlThin
　　　　 .ColorIndex = xlAutomatic
　　　　 End With
　　　　 '右
　　　　 With .Borders(xlEdgeRight)
　　　　 .LineStyle = xlContinuous
　　　　 .Weight = xlThin
　　　　 .ColorIndex = xlAutomatic
　　　　 End With
　　　　End With
　　 Else
　　　　With prerng
　　　　'上
　　　　 With .Borders(xlEdgeTop)
　　　　 .LineStyle = xlContinuous
　　　　 .Weight = xlThin
　　　　 .ColorIndex = xlAutomatic
　　　　 End With
　　　　 '下
　　　　 With .Borders(xlEdgeBottom)
　　　　 .LineStyle = xlContinuous
　　　　 .Weight = xlThin
　　　　 .ColorIndex = xlAutomatic
　　　　 End With
　　　　'左
　　　　 With .Borders(xlEdgeLeft)
　　　　 .LineStyle = xlContinuous
　　　　 .Weight = xlThin
　　　　 .ColorIndex = xlAutomatic
　　　　 End With
　　　　End With
　　 End If
　Else
　　 iti = prerng.Row - r.Row & _
　　　prerng.Column - r.Column & r.Row - NRng.Row & r.Column - NRng.Column
　 'MsgBox cnt & " " & iti
　Select Case iti
　 Case "-10-10"
　　Call kei1
　 Case "-100-1"
　　Call kei2
　 Case "-1001"
　　Call kei3
　 Case "1010"
　　Call kei1
　 Case "100-1"
　　Call kei4
　 Case "1001"
　　Call kei5
　 Case "0-1-10"
　　Call kei5
　 Case "0-110"
　　Call kei3
　 Case "0-10-1"
　　Call kei6
　 Case "01-10"
　　Call kei4
　 Case "0110"
　　Call kei2
　 Case "0101"
　　Call kei6
　End Select
　End If
　If cnt = maxnum Then
　　 If NRng.Address = r.Offset(1).Address Then
　　　　With NRng
　　　　'左
　　　　 With .Borders(xlEdgeLeft)
　　　　 .LineStyle = xlContinuous
　　　　 .Weight = xlThin
　　　　 .ColorIndex = xlAutomatic
　　　　 End With
　　　　'右
　　　　 With .Borders(xlEdgeRight)
　　　　 .LineStyle = xlContinuous
　　　　 .Weight = xlThin
　　　　 .ColorIndex = xlAutomatic
　　　　 End With
　　　　'下
　　　　 With .Borders(xlEdgeBottom)
　　　　 .LineStyle = xlContinuous
　　　　 .Weight = xlThin
　　　　 .ColorIndex = xlAutomatic
　　　　 End With
　　　　End With
　　 ElseIf NRng.Address = r.Offset(-1).Address Then
　　　　With NRng
　　　　'左
　　　　 With .Borders(xlEdgeLeft)
　　　　 .LineStyle = xlContinuous
　　　　 .Weight = xlThin
　　　　 .ColorIndex = xlAutomatic
　　　　 End With
　　　　'右
　　　　 With .Borders(xlEdgeRight)
　　　　 .LineStyle = xlContinuous
　　　　 .Weight = xlThin
　　　　 .ColorIndex = xlAutomatic
　　　　 End With
　　　　'上
　　　　 With .Borders(xlEdgeTop)
　　　　 .LineStyle = xlContinuous
　　　　 .Weight = xlThin
　　　　 .ColorIndex = xlAutomatic
　　　　 End With
　　　　End With
　　 ElseIf NRng.Address = r.Offset(, 1).Address Then
　　　　With NRng
　　　　'右
　　　　 With .Borders(xlEdgeRight)
　　　　 .LineStyle = xlContinuous
　　　　 .Weight = xlThin
　　　　 .ColorIndex = xlAutomatic
　　　　 End With
　　　　'上
　　　　 With .Borders(xlEdgeTop)
　　　　 .LineStyle = xlContinuous
　　　　 .Weight = xlThin
　　　　 .ColorIndex = xlAutomatic
　　　　 End With
　　　　'下
　　　　 With .Borders(xlEdgeBottom)
　　　　 .LineStyle = xlContinuous
　　　　 .Weight = xlThin
　　　　 .ColorIndex = xlAutomatic
　　　　 End With
　　　　End With
　　 Else
　　　　With NRng
　　　　'左
　　　　 With .Borders(xlEdgeLeft)
　　　　 .LineStyle = xlContinuous
　　　　 .Weight = xlThin
　　　　 .ColorIndex = xlAutomatic
　　　　 End With
　　　　'上
　　　　 With .Borders(xlEdgeTop)
　　　　 .LineStyle = xlContinuous
　　　　 .Weight = xlThin
　　　　 .ColorIndex = xlAutomatic
　　　　 End With
　　　　'下
　　　　 With .Borders(xlEdgeBottom)
　　　　 .LineStyle = xlContinuous
　　　　 .Weight = xlThin
　　　　 .ColorIndex = xlAutomatic
　　　　 End With
　　　　End With
　　 End If
　End If
　If cnt > 1 Then
　　 Set prerng = r
　Else
　　 Set prerng = Worksheets(1).Cells(1, 1)
　End If
　NRng.Value = cnt
　Set r = NRng
　Call hukuro
　Application.StatusBar = cnt
　DoEvents
　If hantei = True Then
　　 'bl = True
　　 Call main(maxnum)
　　 Exit Do
　End If
　'Sleep 10
　Sleep 1
　 If cnt = maxnum Then
　　　ws.UsedRange.EntireColumn.AutoFit
　　　 bl = True
　　　MsgBox "完了"
　　　Exit Do
　 End If
　Loop
　'If cnt = maxnum Then MsgBox "完了"
　Set ws = Nothing
End Function

Function nextrng()
Dim Myrnd As Long
Dim chk As Boolean
　chk = True
　Randomize
　Myrnd = Int((saidai - saishou + 1) * Rnd + saishou)
　Select Case Myrnd
　 Case 1
　　If r.Row = 65536 Then
　　　 chk = False
　　Else
　　　 Set NRng = r.Offset(1)
　　End If
　 Case 2
　　If r.Row = 1 Then
　　　 chk = False
　　Else
　　 Set NRng = r.Offset(-1)
　　End If
　 Case 3
　　If r.Column = 256 Then
　　　 chk = False
　　Else
　　　 Set NRng = r.Offset(, 1)
　　End If
　 Case 4
　　If r.Column = 1 Then
　　　 chk = False
　　Else
　　　 Set NRng = r.Offset(, -1)
　　End If
　 End Select
　
　 If chk = False Then
　　　Call nextrng
　 End If
　 If NRng.Value <> "" Then
　　　Call nextrng
　 End If
End Function

Function hukuro()
　 hantei = False
　 If NRng.Row = 1 Then
　　　If NRng.Column = 1 Then
　　　　 If NRng.Offset(1).Value <> "" And NRng.Offset(, 1).Value <> "" Then
　　　　　 hantei = True
　　　　 End If
　　　ElseIf NRng.Column = 256 Then
　　　　 If NRng.Offset(1).Value <> "" And NRng.Offset(, -1).Value <> "" Then
　　　　　　hantei = True
　　　　 End If
　　　Else
　　　　 If NRng.Offset(1).Value <> "" And NRng.Offset(, 1).Value <> "" And NRng.Offset(, -1).Value <> "" Then
　　　　　　hantei = True
　　　　 End If
　　　End If
　 ElseIf NRng.Row = 65536 Then
　　　If NRng.Column = 1 Then
　　　　 If NRng.Offset(-1).Value <> "" And NRng.Offset(, 1).Value <> "" Then
　　　　　　hantei = True
　　　　 End If
　　　ElseIf NRng.Column = 256 Then
　　　　 If NRng.Offset(-1).Value <> "" And NRng.Offset(, -1).Value <> "" Then
　　　　　　hantei = True
　　　　 End If
　　　Else
　　　　 If NRng.Offset(-1).Value <> "" And NRng.Offset(, 1).Value <> "" And NRng.Offset(, -1).Value <> "" Then
　　　　　　hantei = True
　　　　 End If
　　　End If
　 Else
　　　If NRng.Column = 1 Then
　　　　 If NRng.Offset(, 1).Value <> "" And NRng.Offset(-1).Value <> "" And NRng.Offset(1).Value <> "" Then
　　　　　　hantei = True
　　　　 End If
　　　ElseIf NRng.Column = 256 Then
　　　　If NRng.Offset(, -1).Value <> "" And NRng.Offset(1).Value <> "" And NRng.Offset(-1).Value <> "" Then
　　　　　 hantei = True
　　　　End If
　　　Else
　　　　If NRng.Offset(, -1).Value <> "" And NRng.Offset(, 1).Value <> "" And NRng.Offset(1).Value <> "" And NRng.Offset(-1).Value <> "" Then
　　　　　 hantei = True
　　　　End If
　　　End If
　 End If
End Function

Function kei1()
　　With r
　　 '左
　　 With .Borders(xlEdgeLeft)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlThin
　　　　.ColorIndex = xlAutomatic
　　 End With
　　 '右
　　 With .Borders(xlEdgeRight)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlThin
　　　　.ColorIndex = xlAutomatic
　　 End With
　　End With
End Function

Function kei2()
　　With r
　　 '左
　　 With .Borders(xlEdgeLeft)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlThin
　　　　.ColorIndex = xlAutomatic
　　 End With
　　 '下
　　 With .Borders(xlEdgeBottom)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlThin
　　　　.ColorIndex = xlAutomatic
　　 End With
　　End With
End Function

Function kei3()
　　With r
　　 '右
　　 With .Borders(xlEdgeRight)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlThin
　　　　.ColorIndex = xlAutomatic
　　 End With
　　 '下
　　 With .Borders(xlEdgeBottom)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlThin
　　　　.ColorIndex = xlAutomatic
　　 End With
　　End With
End Function

Function kei4()
　　With r
　　 '左
　　 With .Borders(xlEdgeLeft)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlThin
　　　　.ColorIndex = xlAutomatic
　　 End With
　　 '上
　　 With .Borders(xlEdgeTop)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlThin
　　　　.ColorIndex = xlAutomatic
　　 End With
　　End With
End Function

Function kei5()
　　With r
　　 '右
　　 With .Borders(xlEdgeRight)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlThin
　　　　.ColorIndex = xlAutomatic
　　 End With
　　 '上
　　 With .Borders(xlEdgeTop)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlThin
　　　　.ColorIndex = xlAutomatic
　　 End With
　　End With
End Function

Function kei6()
　　With r
　　 '上
　　 With .Borders(xlEdgeTop)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlThin
　　　　.ColorIndex = xlAutomatic
　　 End With
　　 '下
　　 With .Borders(xlEdgeBottom)
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlThin
　　　　.ColorIndex = xlAutomatic
　　 End With
　　End With
End Function

5 hits

▼

【78305】Randomwalk kinoko 16/6/23(木) 17:16