Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
208 / 3841 ﾍﾟｰｼﾞ ←次へ　｜　前へ→
【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
・ツリー全体表示
【78306】Re:Randomwalk
発言  β  - 16/6/23(木) 18:11 -
引用なし
パスワード
   ▼kinoko さん：

>プログラム初心者です。
>ランダムウォークを簡単な処理で作ってみました。

という割には、おもしろそうなことをしておられますね。

>ここから壁に跳ね返る処理

壁　とは　具体的にどこを想定されています？
ＰＣ画面に見えている範囲のことですか？

>色を変えていく処理

どんなように変化させていきたいですか？


ところで、このコード、すぐに行や列の番号が 0 になって、エラーで止まりませんか？
・ツリー全体表示
【78305】Randomwalk
質問  kinoko  - 16/6/23(木) 17:16 -
引用なし
パスワード
   プログラム初心者です。
ランダムウォークを簡単な処理で作ってみました。


Sub randomwalk1()

　　Dim r As Integer
　　Dim c As Integer
　　Dim i As Integer
　　
　　ActiveSheet.Cells.Clear

　　Randomize
　　
　　Cells.RowHeight = 5
　　Cells.ColumnWidth = 0.5
　　
　　r = 50
　　c = 50
　　
　　Cells(r, c).Select
　　
　　For i = 1 To 10000

　　　　i = Int(9 * Rnd() + 1)

　　　　　　If i = 1 Then

　　　　　　　　r = r + 1
　　　　　　　　c = c

　　　　　　　　Cells(r, c).Interior.ColorIndex = 3

　　　　　　ElseIf i = 2 Then

　　　　　　　　r = r + 1
　　　　　　　　c = c + 1

　　　　　　　　Cells(r, c).Interior.ColorIndex = 3

　　　　　　ElseIf i = 3 Then

　　　　　　　　r = r
　　　　　　　　c = c + 1

　　　　　　　　Cells(r, c).Interior.ColorIndex = 3


　　　　　　ElseIf i = 4 Then

　　　　　　　　r = r - 1
　　　　　　　　c = c + 1

　　　　　　　　Cells(r, c).Interior.ColorIndex = 3


　　　　　　ElseIf i = 5 Then

　　　　　　　　r = r - 1
　　　　　　　　c = c

　　　　　　　　Cells(r, c).Interior.ColorIndex = 3

　　　　　　ElseIf i = 6 Then

　　　　　　　　r = r - 1
　　　　　　　　c = c - 1

　　　　　　　　Cells(r, c).Interior.ColorIndex = 3

　　　　　　ElseIf i = 7 Then

　　　　　　　　r = r
　　　　　　　　c = c - 1

　　　　　　　　Cells(r, c).Interior.ColorIndex = 3

　　　　　　ElseIf i = 8 Then

　　　　　　　　r = r + 1
　　　　　　　　c = c - 1

　　　　　　　　Cells(r, c).Interior.ColorIndex = 3

　　　　　　Else

　　　　　　　　r = r
　　　　　　　　c = c

　　　　　　　　Cells(r, c).Interior.ColorIndex = 3

　　　　　　End If

　　Next i

End Sub


ここから壁に跳ね返る処理と重なる部分の色を変えていく処理を追加したいのですが分かりません。簡単な処理でやってみたいです。お願いします。
・ツリー全体表示
【78304】Re:if公式を使ったsum
発言  kamikaya  - 16/6/21(火) 8:43 -
引用なし
パスワード
   ▼if.iserror さん：

みなさんがおっしゃる通りfor〜next文のを使った方がいいかと思います。

>しかし、全くの初心者のため、
>宿題として出された
>if公式の練習として1-10を(1.1)〜(10.1)のセルに埋め
>最後1-10をsumする方法が思いつきません。

スマホから書いてるので動作検証していませんがだいたい次のようになるはずです。

**********************

Sub test '起動するマクロの名前

　 Dim i As Integer 'ループするための変数
　 Dim Sum As Integer '合計値を格納するための変数

　 For i = 1 to 10 'iが1から10になるまで以下を繰り返す(1周毎にiは1増える)
　　　Cells(i, 1).Value = i 'セル(i, 10)にiを記入する
　　　Sum = Sum + i 'Sumに毎回の合計を足していく
　 Next 'for文の繰返しここまでの意

　 Cells(11, 10).Value = Sum 'セル(11, 10)に上記の合計を記入する

End Sub 'マクロ"test"の終了

*********************

個人的にははじめに参考書で専門用語さえ覚えれば、あとはネットでなんとかなると思います(専門用語を知らないと検索さえできないので)。

マクロが組めれば効率が格段にアップするので是非この機会に勉強してみてください。
・ツリー全体表示
【78303】Re:if公式を使ったsum
お礼  ［名前なし］  - 16/6/21(火) 7:58 -
引用なし
パスワード
   取り急ぎスマートフォンからお礼致します。
教えてもらいます。
社会常識がなく、申し訳ありませんでした。
・ツリー全体表示
【78302】Re:if公式を使ったsum
発言  β  - 16/6/21(火) 7:33 -
引用なし
パスワード
   ▼if.iserror さん：

連投失礼。

宿題に対するコード案、その先輩の頭にお中にあるであろう【模範解答】や
通常ならこう書くというコードを提示するのは難しくありません。

でも【宿題】としてだされたわけですよね。
自力で、そのコードが書けないなら、すなおに、できませんでしたといって
先輩から（先輩なりの）回答をもらうのがよろしいのでは？
・ツリー全体表示
【78301】Re:if公式を使ったsum
質問  β  - 16/6/21(火) 7:28 -
引用なし
パスワード
   ▼if.iserror さん：

γさんと同じ感想を持ちました。

かぞえ65なら、そんなに年寄りというわけではありませんけど、その世代って微妙で
実務的には（若いころ）、ゴリゴリのレガシーなプログラムを経験して、そのあとで
構造化プログラミングやオブジェクト指向が登場してきましたけど、それらの実務経験は少なく
頭の中での理解にとどまっている人が少なくありません。（かくいうβも、その一人ですが）

そういう人にとって、ループ制御は、GoTo なんですねぇ。
でも、基本の制御は For/Next や Do/Loop です。

職場の関係、しかも先輩でしょうから、波風たてるのはまずいでしょうから
γさんリコメンドの通り、参考書等での基本的な学習も是非併用してください。
・ツリー全体表示
【78300】Re:if公式を使ったsum
回答  γ  - 16/6/21(火) 7:19 -
引用なし
パスワード
   ▼if.iserror さん：
>if公式の練習として1-10を(1.1)〜(10.1)のセルに埋め
>最後1-10をsumする方法が思いつきません。
ifと余り関係無いように思いますけど。
むしろFor .. Nextによる繰り返しじゃないですか？
宿題はできなくて結構ですから、
その65歳さんに直接お聞きするのがよいと思います。

以下は、感想です。
>教えていただいているのは変数の設定の仕方、
>if,then,go toのみです。
goto は余り使わないし、
スパゲッティプログラムにならないよう、
できるだけgoto は使わないように、
というのが普通です。大丈夫かなあ。

併行して（閉口ではなく）基本的なテキストを購入して、
それを学習することをお勧めします。
こうしたところで、基本的な考え方に属する部分の説明を求めても
効率が悪いです。
・ツリー全体表示
【78299】if公式を使ったsum
質問  if.iserror  - 16/6/21(火) 6:54 -
引用なし
パスワード
   文系、経理業務で3年ほどエクセルの関数を触らせていただいているものです。

最近会社の数えで65歳の先輩と話す機会が増え、
昼休みにVBAを教えていただけることになりました。

しかし、全くの初心者のため、
宿題として出された
if公式の練習として1-10を(1.1)〜(10.1)のセルに埋め
最後1-10をsumする方法が思いつきません。

教えていただいているのは変数の設定の仕方、
if,then,go toのみです。
一応考えているのは(x.1)と設定する方法ですが、いい方法が思いつきません。
他にVBA使っている人に聞いてみると、「その方法ではうまくいかないだろう」とも言われています。

プログラマーの知り合いに聞いたところ、趣味で繋がっているのに、仕事関係の質問は失礼に感じる、そのため教えられないと言われ、こちらを紹介されました。

不躾ではありますが、どなたか、ご親切な方のお助けをいただけないでしょうか。
また、新参者ですので、掲示板上のマナーなどに反するところがあればお教えください（もう少し簡潔に書くなど）

宜しくお願いします。
・ツリー全体表示
【78298】Re:名称未定のテキストファイルの読込み方
お礼  macmac  - 16/6/17(金) 22:41 -
引用なし
パスワード
   ▼γ さま
お返事ありがとうございます。

所定のファイルの中にある文字"JAC"から始まる文字を見つけて
エクセルのセルE1に書き出す内容を作っております。

（所定のファイルは、C:\Tempに保存されているtxtファイルで名称は、日々更新されるものです。）


Sub Sample()
　Dim PartsID As String
　Dim i As Integer
　For i = 6 To 6 'Cells(Rows.Count, 3).End(xlUp).Row
　PartsID = Cells(i, 3)
　PartsID = Left(PartsID, 11)
　Debug.Print PartsID
　Call FileSearch("C:\Temp", PartsID & "*.txt")
　　　
　Next
End Sub

Sub FileSearch(Path As String, Target As String)
　　Dim FSO As Object, Folder As Variant, File As Variant
　　Dim strFILENAME As Variant
　　Dim info As String
　　Dim s As String
　　Dim a As String
　　Dim fNo As Integer
　　
　　Set FSO = CreateObject("Scripting.FileSystemObject")
　　For Each Folder In FSO.GetFolder(Path).SubFolders
　　　　Call FileSearch(Folder.Path, Target)
　　Next Folder
　　For Each File In FSO.GetFolder(Path).Files
　　　　If File.Name Like Target Then
　　　　strFILENAME = File.Path

'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
　　　　
　　 fNo = FreeFile
　　 s = "JAC"
　　 Debug.Print strFILENAME
　　 Open strFILENAME For Input As #fNo
　　 While Not EOF(1)
　　 Line Input #1, a
　　 If InStr(1, a, s) <> 0 Then
　　 info = Mid(a, 1, InStr(1, a, s) + 30)
　　 Debug.Print info
　　 End If
　　 Wend
　　 Close #fNo
　　　　
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
　　 End If
　　 Next File

　　 End Sub
・ツリー全体表示
【78297】Re:グラフを右クリック時のメニュー追加
発言  kamikaya  - 16/6/17(金) 21:05 -
引用なし
パスワード
   ▼kamikaya さん：

解決しました。
新規にグラフを追加した際にはNewChartイベントが発生するみたいなので次のように改良しました。

またNorthさんの追加したい項目が"調整"となっていましたが，これはグラフのサイズなどを調整するということでしょうか??
もしそうでしたらVectorでグラフ調整ソフト"GrapgAdjust"というものを配布しているので良ければ使ってみてください(ステマ(笑))

【Microsoft Excel Objects ThisWorkbook】

Option Explicit

Private WithEvents xApp As Application

'■アドインファイル(これ)が起動したとき…
Private Sub Workbook_Open()

　　' アドイン起動時、Applicationオブジェクトのイベントをキャッチ
　　Set xApp = Me.Application
　　
　　'独自右クリックメニューの作成
　　subSettingMyMenu
　
End Sub

'■既存のブックが開いたとき…
Private Sub xApp_WorkbookOpen(ByVal wb As Workbook)

　　Dim Chrt As ChartObject
　　Dim WS As Worksheet

　　'グラフの割り当て
　　For Each WS In wb.Worksheets
　　　　For Each Chrt In WS.ChartObjects
　　　　　　subChartEventSetting Chrt.Chart
　　　　Next
　　Next

End Sub

'■新規ブックが作成されたとき…(新規ブックにはグラフはないはずなので要らないかも)
Private Sub xApp_NewWorkbook(ByVal wb As Workbook)

　　Dim Chrt As ChartObject
　　Dim WS As Worksheet

　　For Each WS In wb.Worksheets
　　　　For Each Chrt In WS.ChartObjects
　　　　　　subChartEventSetting Chrt.Chart
　　　　Next
　　Next

End Sub

'■新しくグラフが追加されたとき…
Private Sub xApp_WorkbookNewChart(ByVal wb As Workbook, ByVal Ch As Chart)

　　'グラフの割り当て
　　subChartEventSetting Ch
　　
End Sub

【標準モジュール】

Option Explicit

Public MyMenu
Public MyMenu2
Private ChrtEvents As New Collection

'■グラフの割り当て
Public Sub subChartEventSetting(Ch As Chart)

　　 'アクティブブック上のすべてのグラフに独自右クリックメニューを割り当てる
　　Dim ChartEvent As New Class1
　　Set ChartEvent.xChart = Ch
　　ChrtEvents.Add ChartEvent

End Sub

'■独自右クリックメニューの作成
Public Sub subSettingMyMenu()

　　Dim i As Integer

　　Set MyMenu = Application.CommandBars.Add(Position:=msoBarPopup, Temporary:=True)
　　With MyMenu
　　　　With .Controls.Add
　　　　　　.Caption = "Test"
　　　　　　.OnAction = "subTest"
　　　　End With
　　End With
　
End Sub

'■最終的に実行したいマクロ
Private Sub subTest()

　　MsgBox "Hello world"

End Sub

'■何らかの原因でイベント処理が割り当てられなかったとき用の手動割り当て
Sub 実行するマクロ()

　　Dim Chrt As ChartObject
　　Dim WS As Worksheet

　　'独自右クリックメニューの作成
　　subSettingMyMenu

　　'グラフの割り当て
　　For Each WS In ActiveWorkbook.Worksheets
　　　　For Each Chrt In WS.ChartObjects
　　　　　　subChartEventSetting Chrt.Chart
　　　　Next
　　Next
　　
End Sub

【クラスモジュール(Class1)】

Option Explicit

Public WithEvents xChart As Chart

'■グラフ上でマウスボタンが押されたら…
Private Sub xChart_MouseDown(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)

　　If Button = 2 Then
　　　　If Shift = 1 Then
　　　　　　MyMenu.ShowPopup
　　　　End If
　　End If

End Sub
・ツリー全体表示
【78296】Re:名称未定のテキストファイルの読込み方
回答  γ  - 16/6/17(金) 20:47 -
引用なし
パスワード
   Open strFILENAME For Input As #fNo
というのは、そのファイルにアクセスする権限を得た、
という感じのものです。

なにかのWIndowにテキストが表示されるというようなことを
期待していたとすると、その期待そのものが間違っています。

Input
Line Input などのステートメントでデータを取得する必要があります。

フォルダの配下にあるフォルダも含めて、各ファイルを開いて何をするか、
によって適切な"開く"手段を選ぶ必要があるでしょう。
・ツリー全体表示
【78295】Re:グラフを右クリック時のメニュー追加
質問  kamikaya  - 16/6/17(金) 15:18 -
引用なし
パスワード
   ▼kamikaya さん：

ちょっと加筆修正しました。

下記のコードはアドインファイルに記述します。既存のブックが開かれるたびにグラフの割り当てを自動的に行います。

ただし，これの問題はすでに開いているブックで新たにグラフを作成した場合，そのグラフには手動でイベント割り当てを行う必要があります(そのためのマクロ"実行するマクロ")。

逆質問で申し訳ないのですが，シート上でグラフが新規作成された場合にイベントを発生させる方法を知っている方がいらっしゃいましたらご教授のほどお願いします。

【Microsoft Excel Objects ThisWorkbook】

Option Explicit

Private WithEvents xApp As Application

'■アドインファイル(これ)が起動したとき…
Private Sub Workbook_Open()

　　' アドイン起動時、Applicationオブジェクトのイベントをキャッチ
　　Set xApp = Me.Application
　　
End Sub

'■既存のブックが開いたとき…
Private Sub xApp_WorkbookOpen(ByVal WB As Workbook)

　　'グラフの割り当て
　　subChartEventSetting WB

End Sub

【標準モジュール】

Option Explicit

Public MyMenu
Private ChrtEvents As New Collection

'■はじめに起動する場所
Sub 実行するマクロ()

　　subChartEventSetting ActiveWorkbook

End Sub

'■グラフの割り当て
Public Sub subChartEventSetting(WB As Workbook)

　　'独自右クリックメニューの作成
　　subSettingMyMenu

　　'独自右クリックメニューのグラフへの割り当て
　　Dim CH As ChartObject
　　Dim WS As Worksheet
　　
　　'アクティブブック上のすべてのグラフに独自右クリックメニューを割り当てる
　　For Each WS In WB.Worksheets
　　　　For Each CH In WS.ChartObjects
　　　　　　Dim ChartEvent As New Class1
　　　　　　Set ChartEvent.xChart = CH.Chart
　　　　　　ChrtEvents.Add ChartEvent
　　　　Next
　　Next

End Sub

'■独自右クリックメニューの作成

Private Sub subSettingMyMenu()

　　Set MyMenu = Application.CommandBars.Add(Position:=msoBarPopup, Temporary:=True)
　　With MyMenu
　　　　With .Controls.Add
　　　　　　.Caption = "Test"
　　　　　　.OnAction = "subTest"
　　　　End With
　　End With
　　
End Sub

'■最終的に実行したいマクロ

Private Sub subTest()

　　MsgBox "Hello world"

End Sub

【クラスモジュール(Class1)】

Option Explicit

Public WithEvents xChart As Chart

'■グラフ上でマウスボタンが押されたら…
Private Sub xChart_MouseDown(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)

　　If Button = 2 Then
　　　　If Shift = 1 Then
　　　　　　MyMenu.ShowPopup
　　　　End If
　　End If

End Sub
・ツリー全体表示
【78294】Re:グラフを右クリック時のメニュー追加
お礼  North  - 16/6/17(金) 14:45 -
引用なし
パスワード
   kamikayaさん
ご回答ありがとうございます。本当に助かります。
提示いただいたコードを参考にやってみます。
また不明点など出てきたら質問させていただきます。
・ツリー全体表示
【78293】Re:グラフを右クリック時のメニュー追加
発言  kamikaya  - 16/6/17(金) 14:36 -
引用なし
パスワード
   ▼North さん：

先ほども言ったように，グラフの既存の右クリックメニューへの追加はできませんが，以下のように独自の右クリックメニューを作成することはできます。

下記のコードをそれぞれのモジュールにコピーして，プロシージャ"実行するマクロ"を実行してみてください。

グラフ上で[Shift]キーを押しながら右クリックを押すことで独自右クリックメニュー(Test)がポップアップするようになっています。

※これでは各ブックで行わなくてはならないので，実装するならアドインファイルとした方が良いかと思います。

【Microsoft Excel Objects ThisWorkbook】

Private WithEvents xApp As Application

【標準モジュール】

Option Explicit

Public MyMenu
Private ChrtEvents As New Collection

'■はじめに起動する場所
Sub 実行するマクロ()

　　'独自右クリックメニューの作成
　　subSettingMyMenu

　　'独自右クリックメニューのグラフへの割り当て
　　Dim CH As ChartObject
　　Dim WS As Worksheet
　　
　　'アクティブブック上のすべてのグラフに独自右クリックメニューを割り当てる
　　For Each WS In ActiveWorkbook.Worksheets
　　　　For Each CH In WS.ChartObjects
　　　　　　Dim ChartEvent As New Class1 '"Class1"の箇所はクラスモジュールの名前と揃える
　　　　　　Set ChartEvent.xChart = CH.Chart
　　　　　　ChrtEvents.Add ChartEvent
　　　　Next
　　Next

End Sub

'■独自右クリックメニューの作成
Private Sub subSettingMyMenu()

　　Set MyMenu = Application.CommandBars.Add(Position:=msoBarPopup, Temporary:=True)
　　With MyMenu
　　　　With .Controls.Add
　　　　　　.Caption = "Test"　　　　 'そちらの"調整"に相当
　　　　　　.OnAction = "subTest"　　 'そちらの"mAdj"に相当
　　　　End With
　　End With
　　
End Sub

'■最終的に実行したいマクロ

Private Sub subTest()

　　MsgBox "Hello world"

End Sub

【クラスモジュール(Class1)】

Option Explicit

Public WithEvents xChart As Chart
Dim Flag As Boolean

'■グラフ上でマウスボタンが押されたら…
Private Sub xChart_MouseDown(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)

　　If Button = 2 Then
　　　　If Shift = 1 Then
　　　　　　MyMenu.ShowPopup
　　　　End If
　　End If
　　Flag = True

End Sub

'■グラフが右クリックされたら…
Private Sub xWorksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

　　If Flag = True Then
　　　　Cancel = True
　　　　Flag = False
　　End If

End Sub
・ツリー全体表示
【78292】Re:指定フォルダオープンを自ブック所在...
お礼  KEN  - 16/6/17(金) 13:26 -
引用なし
パスワード
   βさん。
できました！
どうもありがとうございました！！
・ツリー全体表示
【78291】Re:指定フォルダオープンを自ブック所在...
発言  β  - 16/6/17(金) 11:53 -
引用なし
パスワード
   ▼KEN さん：

単純に、Shell(文字列,vbNormalFocus) この文字列についてみますと

"explorer.exe C:\TEST\abc"

これは

explorer.exe●C:\TEST\abc

ですね（●は半角スペース）

一方、

"explorer.exe & ""ThisWorkbook.Path " & " \abc\"""

これは

explorer.exe●&●"c:\hoge\hogehoge\hogehogehoge●●\abc\"

こうなってしまいますね。

定数である　C:\TEST\abc　を 変数と定数の連結にするわけですから

Shell("explorer.exe " & ThisWorkbook.PAth & "\abc", vbNormalFocus)

ではないでしょうか？
・ツリー全体表示
【78290】Re:マクロのアプリケーション画面を自動...
発言  β  - 16/6/17(金) 11:40 -
引用なし
パスワード
   ▼へいへい さん：

昔、こんな話題を見かけた記憶もありますが、すっかり忘却の彼方です。仮に、

Sub Try()
　　Application.SendKeys "%{F11}"
　　DoEvents
　　Application.SendKeys "%{F11}"
End Sub

こんなマクロを使って、ＶＢＥ画面を一瞬表示させて、うまくいったとします。
（これだけではうまくいかないような気もしますが）
でも、本当の原因はどこかにあるわけで、このような小手先の対応をするのは
あまり感心しません。

また、どのマクロを実行してもエラーになるなら、このマクロ実行そのものもできないかも？

まず、問題を切り分ければいかがでしょう。

・そもそも、エラー　とは、どういう状態なのか。
　実行時エラーになるのか、わけのわからないメッセージがでて実行が拒否されるのか
　あるいは、エクセルが固まるのか、さらにはエクセルが落ちてしまうのか。
　そのときに出されるエラー番号とメッセージでネット検索すると、なにか同じ状況の報告が
　あるかもしれません。

・エラーになるのは、特定のモジュールの特定のマクロ？
　それとも、特定のモジュールのマクロすべてか？
　あるいは、別モジュールも含めて、すべてのマクロか？


　特定のマクロということであれば、そのマクロそのものに問題がある公算大です。
　その場合はコードを見る必要があるでしょう。

　特定のモジュールのマクロすべてであれば、そのモジュールが何かおかしくなっているかもしれません。
　もしかしたら、先頭に記述された Option hogeといったものと、エクセル環境があわないのかもしれません。
　（考えにくいですが）
　あるいは、モジュールが破壊されている？　であれば　エクスポート付開放を行ったうえでインポートとか
　そのモジュールの記述内容をメモ帳あたりにコピーしておいて、モジュールを削除。新規モジュールを挿入して
　そこにメモ帳からコードを移植。
　
といったことを、地道に調べてみたらいかがでしょう。
・ツリー全体表示
【78289】指定フォルダオープンを自ブック所在のフ...
質問  KEN  - 16/6/17(金) 11:35 -
引用なし
パスワード
   VBA初心者です。
指定フォルダオープンをShell("explorer.exe で作成しています。

アドレスを直で入力すると、うまく動きます。
Shell("explorer.exe C:\TEST\abc", vbNormalFocus)

しかし、アドレス直ではなく、自ブック所在のフォルダにしたいです。
Shell("explorer.exe & ""ThisWorkbook.Path " & " \abc\""", vbNormalFocus)
ではうまく動きません。

どこがおかしいでしょうか。
また、そもそも自ブック所在の場合は、書き方が違いますでしょか。

よろしくお願いします。
・ツリー全体表示
【78288】Re:マクロのアプリケーション画面を自動...
発言  へいへい  - 16/6/17(金) 9:35 -
引用なし
パスワード
   自分で作ったマクロですが、起動させるとエラーが発生してしまいます。しかし、ＶＢＡ画面を開いて閉じるという工程を行うと、問題なくマクロが起動するので、その工程を自動で行えれば、使用前に手動で行わないで済むということから質問いたしました。
・ツリー全体表示
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
208 / 3841 ﾍﾟｰｼﾞ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free