Excel VBA質問箱 IV

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

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


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

3484 / 13645 ﾂﾘｰ

←次へ　｜　前へ→

▼

【61498】新しいウインドを開くのウインドウを閉じるときイベント ON 09/5/13(水) 17:57

【61504】Re:新しいウインドを開くのウインドウを閉... n 09/5/13(水) 22:40

【61507】Re:新しいウインドを開くのウインドウを閉... yoshi 09/5/14(木) 2:26

【61515】Re:新しいウインドを開くのウインドウを閉... neptune 09/5/14(木) 10:19

【61604】Re:新しいウインドを開くのウインドウを閉... ON 09/5/21(木) 16:18

【61615】Re:新しいウインドを開くのウインドウを閉... neptune 09/5/21(木) 22:31

【61619】Re:新しいウインドを開くのウインドウを閉... n 09/5/22(金) 1:37

【61624】Re:新しいウインドを開くのウインドウを閉... yoshi 09/5/22(金) 11:59

【61690】Re:新しいウインドを開くのウインドウを閉... ON 09/5/27(水) 18:44

【61723】Re:新しいウインドを開くのウインドウを閉... ON 09/5/29(金) 21:15

【61737】Re:新しいウインドを開くのウインドウを閉... yoshi 09/5/30(土) 16:19

【61804】Re:新しいウインドを開くのウインドウを閉... ＯＮ 09/6/5(金) 16:17

【61808】Re:新しいウインドを開くのウインドウを閉... yoshi 09/6/5(金) 18:17

【61809】Re:新しいウインドを開くのウインドウを閉... ＯＮ 09/6/5(金) 19:10

【61817】Re:新しいウインドを開くのウインドウを閉... yoshi 09/6/6(土) 16:54

【61930】Re:新しいウインドを開くのウインドウを閉... ON 09/6/12(金) 16:36

【61931】Re:新しいウインドを開くのウインドウを閉... ON 09/6/12(金) 16:37

【61932】Re:新しいウインドを開くのウインドウを閉... ON 09/6/12(金) 16:39


	【61498】新しいウインドを開くのウインドウを閉じ...

ON - 09/5/13(水) 17:57 -


	引用なし

	パスワード

こんにちは　よろしくお願いいたします

メニュー/ウインドウ/新しいウインドウを開く
メニュー/ウインドウ/整列/左右に並べて表示
hoge.xls:1，hoge.xls:2
のようにしているとき
ブックの×ボタンで閉じられないようにしたいと思っていますが
上記に相当するイベントは無いようです

（複数ウインドウ時　hoge.xls:1，hoge.xls:2　の場合の、1方を閉じるときです）

どうすれば出来るでしょうか

アドバイスよろしくお願いします

取りあえずのコードは下記のようになっています

ThisWorkbookモジュール

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)

　　If bk_close Then
　　
　　　　ActiveWindow.WindowState = xlMaximized
　　　　MsgBox "閉じる"
　　　　
　　　　Cancel = False
　　Else
　　
　　　　MsgBox "×ボタン使用不可"
　　　　Cancel = True
　　　　
　　End If

End Sub

Private Sub Workbook_Open()

bk_close = True

test1

End Sub

---------------------------------------------------------------

標準モジュール

Option Explicit

Public bk_close As Boolean

Public Sub test1()

　　Dim max_h As Double
　　Dim max_w　As Double
　　Dim count_window As Integer
　　
　　ActiveWindow.WindowState = xlMaximized
　　
　　max_h = ActiveWindow.Height - 20.25　'なぜか-20.25　必要

　　　　
　　max_w = ActiveWindow.Width
　　
　　'count_window = Application.Windows.Count
　　
　　ActiveWindow.Caption = "メイン"
　　Windows("メイン").Activate
　　With ActiveWindow
　　　　.WindowState = xlNormal
　　　　.Top = 1
　　　　.Left = 1
　　　　.Height = max_h
　　　　'.Width = 300
　　　　.Width = 140
　　　　
　　End With
　　
　　ActiveWindow.NewWindow.Caption = "サブ"
　　Windows("サブ").Activate
　　With ActiveWindow
　　　　.WindowState = xlNormal
　　　　.Top = 1
　　　　'.Left = 300
　　　　.Left = 142
　　　　.Height = max_h
　　　　'.Width = max_w - 300
　　　　.Width = max_w - 142
　　End With

End Sub


	【61504】Re:新しいウインドを開くのウインドウを...

n - 09/5/13(水) 22:40 -


	引用なし

	パスワード

>hoge.xls:1，hoge.xls:2 >のようにしているとき >ブックの×ボタンで閉じられないようにしたいと思っていますが >上記に相当するイベントは無いようです > >（複数ウインドウ時　hoge.xls:1，hoge.xls:2　の場合の、1方を閉じるときです）常に２つのWindowを左右並べで整列させて、片方を閉じさせないという意味でしょうか？かん違いしていなければ、閉じた場合強制で復活させて整列し直す、という対応でも良い？ 'ThisWorkbookModule Option Explicit Private bk_close　As Boolean '----------------------------------------------------------- Private Sub Workbook_BeforeClose(Cancel As Boolean) 　　bk_close = True End Sub '----------------------------------------------------------- Private Sub Workbook_Open() 　　test1 End Sub '----------------------------------------------------------- Private Sub Workbook_WindowDeactivate(ByVal Wn As Window) 　　If Not bk_close Then 　　　　Application.OnTime Now, Me.CodeName & ".wnChk" 　　End If End Sub '----------------------------------------------------------- Sub wnChk() 　　If Me.Windows.Count <> 2 Then 　　　　test1 　　End If End Sub '----------------------------------------------------------- Sub test1() 　　Dim max_h　 As Double 　　Dim max_w　 As Double 　　Dim count_w As Long 　　Dim i　　　 As Long 　　　　Application.EnableEvents = False 　　With Me 　　　　count_w = .Windows.Count 　　　　If count_w > 2 Then 　　　　　　For i = count_w To 3 Step -1 　　　　　　　　.Windows(i).Close 　　　　　　Next 　　　　ElseIf count_w = 1 Then 　　　　　　.NewWindow 　　　　End If 　　　　With .Windows(1) 　　　　　　.WindowState = xlMaximized 　　　　　　max_h = .Height - 20.25　'なぜか-20.25　必要　　　　　　max_w = .Width 　　　　　　.WindowState = xlNormal 　　　　　　.Top = 1 　　　　　　.Left = 1 　　　　　　.Height = max_h 　　　　　　'.Width = 300 　　　　　　.Width = 140 　　　　　　.Caption = "メイン" 　　　　End With 　　　　With .Windows(2) 　　　　　　.Top = 1 　　　　　　'.Left = 300 　　　　　　.Left = 142 　　　　　　.Height = max_h 　　　　　　'.Width = max_w - 300 　　　　　　.Width = max_w - 142 　　　　　　.Caption = "サブ" 　　　　End With 　　End With 　　Application.EnableEvents = True End Sub


	【61507】Re:新しいウインドを開くのウインドウを...

yoshi - 09/5/14(木) 2:26 -


	引用なし

	パスワード

>メニュー/ウインドウ/新しいウインドウを開く
>メニュー/ウインドウ/整列/左右に並べて表示
>hoge.xls:1，hoge.xls:2
>のようにしているとき
>ブックの×ボタンで閉じられないようにしたいと思っていますが
>上記に相当するイベントは無いようです
>（複数ウインドウ時　hoge.xls:1，hoge.xls:2　の場合の、1方を閉じるときです）
>どうすれば出来るでしょうか

簡単で確実なのは、ブックの保護(ウィンドウをチェック)をすることでは。
必要により保護したり解除したりすればいいのでは...


	【61515】Re:新しいウインドを開くのウインドウを...

neptune - 09/5/14(木) 10:19 -


	引用なし

	パスワード

▼ON さん：
こんにちは

昔ですが、以下のような方法を取った事あります。

１．ExcelのHWND取得
２．１のHWNDを利用してクライアントウィンドウのHWND取得
３．２のHWNDを利用して、BookのHWND取得
４．３のHWNDを利用して、Bookのシステムメニューの閉じるボタンを無効にする
ってな方法があります。

HWNDに関しては
findwindowexを使うとか、EnumChildwindowを使うとか実現の方法はいろいろあると思います。

ウィンドウのクラス名に関しては
ExcelのバージョンによってBookのクラス名が違うと思うので、SPY++をお持ちであれば
簡単ですが、なくても予め、EnumChildwindow、GetClassName等で調べられると思います。

システムメニューに関しては
UserFormの×ボタンを無効にする方法と同じ方法で大丈夫だと思います。
から、これはExcelの掲示板で検索すれば沢山ヒットすると思います。

・・・・と偉そうに書きましたが、胸を張って人様にお勧めするほどの検証はした事ありませんので
そこの所はご自分で判断下さい。

まぁAPIを考えるのは最後の手段で充分とは思いますので、今取っておられる
方法や、他の方のアドバイスを先に検討するのが良いとは思います。


	【61604】Re:新しいウインドを開くのウインドウを...

ON - 09/5/21(木) 16:18 -


	引用なし

	パスワード

皆様　レス頂ながら大変遅くなりました　m(_ _)m

n さん　こんにちは　いつもありがとうございます

>常に２つのWindowを左右並べで整列させて、片方を閉じさせないという意味でしょうか？
です
>かん違いしていなければ、閉じた場合強制で復活させて整列し直す、という対応でも良い？
コードのご提示ありがとうございます

Application.OnTime　
色々教えて頂いていますがなかなか身についていないです
こういう利用のほうほうもあるのですか
勉強になります

動作的には
1ブック時でマクロ記載ブックは、必ず2ウインドウ開かせる
の制御はなんとなく理解できたつもりです

ただ、他ブックが開いて最大化しておいても
ウインドウ切り替えで、最大化が切り替えられ
当該ブックを選択すると2画面表示にはならなくなります

ちょっと状況がわかりにくいと思いますが・・・・

この辺、neptuneさん　アドバイスのAPIあたりでウインドウズの制御が
必要な気もしてきました

一般方法で少しチャレンジしてみましたが
最大化とそうでない場合で取得に差があったりしていまいち？？でした

? ActiveWindow.Application.Caption
? ActiveWindow.Caption
? activeworkbook.Name
? activeworkbook.Application.Caption

タイトルバーのCaptionを変えてしまっているので、この辺も影響してきそうな感じもしていますが・・

yoshi さん　こんにちは　ありがとうございます

>簡単で確実なのは、ブックの保護(ウィンドウをチェック)をすることでは。

ブックの保護(ウィンドウをチェック)で
ブックの最小・最大・終了×ボタンが非表示なるなんて知りませんでした
ちょっと驚きです

>必要により保護したり解除したりすればいいのでは…
そんな気がしますが使用したことがないので動作がよくわかりません
ただ、複数ブックを開いた場合は、n さん　のときの状況と同じになってしまいました

説明しにくいのですが下記テストしてみました

Aブック：一般ブック1
Bブック：一般ブック2
Cブック：当初コード付ブック

テスト1
Aブックを開くと最大化で開きます
続けてBブックを開くと最大化で開きます

テスト2
Aブックを開くと最大化で開きます
Aブックを、右上　元のサイズに戻す　と、少しちいさくなります
続けてBブックを開くと最大化でないウインドウサイズで開きます
この状態でBブックを閉じると、Aブックは最大化されます

・・・・
どういうテストをしたらいいのかよくわからないのですが
他に、ブックを開いたとき、最大化されているときと
元のサイズで開かれるときとあるような気がします

だいたい、元のブックのサイズとはいったい何なのかよくわかりません

ブックのウインドウサイズがなにによって影響を受けるのでしょうか
解説頂ければ助かります　よろしくお願いいたします

実際の
行いたい動作は
Cブックは2画面表示
その他のブックが存在しているとき、タスクバーで選択されたときは最大化して表示
その後、Cブックを選択しても2画面表示
したいと思っています・・・・

最悪、1ブックでの限定使用も考えていますが・・・・
出来れば、
利用者の立場で考えて
複数ブック起動時でも、違和感なく使えるものにしたいと考えています
上記が違和感がないか自信はありませんが・・・・

neptune さん　こんにちは　ありがとうございます

APIでのアプローチ方法ありがとうございます

サンプルが見つかったので背伸びして少しチャレンジしてみました

Excelブックの最大化、最小化、×ボタン非表示
ht　tp://blogs.yahoo.co.jp/chika_z/1095067.html
で
>ちなみにExcelアプリケーションの場合は、
>hwnd = FindWindow("XLMAIN", sAppCaption)
>だけで取れるけどね。

を参考に

Option Explicit

Private Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Public Function get_hwnd()

　　uu = FindWindow("XLMAIN", ActiveWindow.Application.Caption)

End Function

? get_hwnd
6947744

は、複数ブック開いていても取得出来ました

なぜか、昨日は取得できなかったような・・・・

ちょっと気になっているのが
?activewindow.Application.Caption
での返り値は
ブックのウインドウが最大化されていないとき：Microsoft Excel
ブックのウインドウが最大化されているとき　：Microsoft Excel - hoge.xls
でブック名がなくてもアプリケーションのhwndは取得できますが・・・
ブックウインドウのhwndは取得できていませんが・・・

リンク先記載の、XLMAIN/XLDESK/EXCEL7　の理解はまだ出来ていません

また
２４．すべてのウインドウを列挙する
ht　tp://homepage1.nifty.com/MADIA/vb/API/EnumWindows.htm
では、各ブックのhwndは取得できました
こちらも、理解するにはいたっていませんが・・・

取りあえずの途中報告でした
何かアドバイスありましたらよろしくお願いいたします

返信が遅くなってしまうような状況ですがよろしくお願いいたします


	【61615】Re:新しいウインドを開くのウインドウを...

neptune - 09/5/21(木) 22:31 -


	引用なし

	パスワード

▼ON さん：
このサンプルは理解の助けになるでしょうか？

GetAllWindowsClassName
を実行すると、Sheet1にExcelアプリケーションの子ウィンドウのクラス名と、
そのウィンドウのTitleバーのText列挙されます。
これで複数のBookがあっても、各Bookのクラス名とtitleが取得できます。

Private Declare Function EnumChildWindows Lib "user32.dll" _
　　　　　　　　　　　　(ByVal hWndParent As Long, _
　　　　　　　　　　　　 ByVal lpEnumFunc As Long, _
　　　　　　　　　　　　 lParam As Long) As Long

Private Declare Function FindWindow Lib "user32" _
　　　　　　　　　　　　Alias "FindWindowA" _
　　　　　　　　　　　 (ByVal lpClassName As String, _
　　　　　　　　　　　　ByVal lpWindowName As String) As Long
　　　　
Private Declare Function FindWindowEx Lib "user32" _
　　　　　　　　　　　　Alias "FindWindowExA" _
　　　　　　　　　　　 (ByVal hWnd1 As Long, _
　　　　　　　　　　　　ByVal hWnd2 As Long, _
　　　　　　　　　　　　ByVal lpsz1 As String, _
　　　　　　　　　　　　ByVal lpsz2 As String) As Long
　　　　
Private Declare Function GetClassName Lib "user32.dll" _
　　　　　　　　　　　　Alias "GetClassNameA" _
　　　　　　　　　　　 (ByVal hWnd As Long, _
　　　　　　　　　　　　ByVal lpClassName As String, _
　　　　　　　　　　　　ByVal nMaxCount As Long) As Long
　　　　
Private Declare Function GetWindowText Lib "user32.dll" _
　　　　　　　　　　　　Alias "GetWindowTextA" _
　　　　　　　　　　　 (ByVal hWnd As Long, _
　　　　　　　　　　　　ByVal lpString As String, _
　　　　　　　　　　　　ByVal nMaxCount As Long) As Long
　　　　　　　　　　　　　　　　
Private Const cExcelClassName　As String = "XLMAIN"

Private Sub GetAllWindowsClassName()
Dim hWnd As Long
Dim sBuf As String * 512
Dim sTitle As String
Dim lret As Long

　　hWnd = FindWindow(cExcelClassName, Application.Caption)
　　lret = GetWindowText(hWnd, sBuf, Len(sBuf))
　　sTitle = Left(sBuf, InStr(sBuf, vbNullChar) - 1)
　　With Worksheets("Sheet1")
　　　　.Range("A1").Value = "ClassName"
　　　　.Range("B1").Value = "Caption"
　　　　.Range("A2").Value = cExcelClassName
　　　　.Range("B2").Value = sTitle
　　End With
　　
　　Call EnumChildWindows(hWnd, AddressOf EnumChildWindowsProc, 0&)
　　
End Sub

'これはどこかにあった奴を保存してたので改造して使ってます。
Private Function EnumChildWindowsProc(ByVal hChild As Long, _
　　　　　　　　　　　　　　　　　lParam As Long) As Long
　　Dim sBuff As String * 128
　　Dim sBuff2 As String * 516
　　Dim ret As Long
　　Dim sClassName As String
　　Dim sTitle As String
　　Dim lCount As Long
　　
　　lCount = GetLoastRow + 1
　　'クラス名取得
　　ret = GetClassName(hChild, sBuff, Len(sBuff))
　　sClassName = Left(sBuff, InStr(sBuff, vbNullChar) - 1)
　　
　　ret = GetWindowText(hChild, sBuff2, Len(sBuff2))
　　sTitle = Left(sBuff2, InStr(sBuff2, vbNullChar) - 1)
　　
　　Worksheets("Sheet1").Range("A" & CStr(lCount)).Value = sClassName
　　Worksheets("Sheet1").Range("B" & CStr(lCount)).Value = sTitle
　　
　　EnumChildWindowsProc = True
End Function

Private Function GetLoastRow() As Long
　　Dim ret As Long
　　
　　ret = Worksheets("Sheet1").Range("A" & CStr(Application.Rows.Count)).End(xlUp).Row
　　GetLoastRow = ret
End Function

以下APIの解説
ht tp://msdn.microsoft.com/ja-jp/library/cc364600.aspx
ht tp://msdn.microsoft.com/ja-jp/library/cc410802.aspx
ht tp://msdn.microsoft.com/ja-jp/library/cc410835.aspx
ht tp://msdn.microsoft.com/ja-jp/library/cc410853.aspx
ht tp://msdn.microsoft.com/ja-jp/library/cc364815.aspx

>ちょっと気になっているのが
??activewindow.Application.Caption
?での返り値は
>ブックのウインドウが最大化されていないとき：Microsoft Excel
>ブックのウインドウが最大化されているとき　：Microsoft Excel - hoge.xls
なんですが、ExcelはMDIアプリケーションなのでその子ウィンドウ
(この場合Book）が最大化された時、親ウィンドウのタイトルバー（一番上の
閉じるボタンなどがある所）に
Microsoft Excel - hoge.xls
となるのは
そういうスタイル指定は出来なかったと思うので、MDIWindowの仕様のような
気がします。・・・・自信なし


	【61619】Re:新しいウインドを開くのウインドウを...

n - 09/5/22(金) 1:37 -


	引用なし

	パスワード

'ThisWorkbookModule Option Explicit Private bk_close As Boolean Private WithEvents xlApp As Application '● '----------------------------------------------------------- Private Sub Workbook_BeforeClose(Cancel As Boolean) 　　bk_close = True 　　Me.Windows(1).WindowState = xlMaximized '● 　　Set xlApp = Nothing '● End Sub '----------------------------------------------------------- Private Sub Workbook_Open() 　　Set xlApp = Application '● 　　test1 End Sub '----------------------------------------------------------- Private Sub Workbook_WindowDeactivate(ByVal Wn As Window) 　　'（省略） End Sub '----------------------------------------------------------- Sub wnChk() 　　'（省略） End Sub '----------------------------------------------------------- Sub test1() 　　'（省略） End Sub '----------------------------------------------------------- Private Sub xlapp_WindowActivate(ByVal Wb As Workbook, _ 　　　　　　　　　　　　　　　　 ByVal Wn As Window) '● 　　Dim w As Window 　　　　If Wb Is Me Then 　　　　Wn.WindowState = xlNormal 　　　　xlApp.EnableEvents = False 　　　　For Each w In Wb.Windows 　　　　　　w.Activate 　　　　Next 　　　　Wn.Activate 　　　　xlApp.EnableEvents = True 　　Else 　　　　Wn.WindowState = xlMaximized 　　End If End Sub '●が追加です。あと、『サブ』を閉じた時、test1で『メイン』と『サブ』が入れ替わっちゃいますけど、それで不都合あるならCaptionで判断して分岐処理するなど、工夫してみてください。


	【61624】Re:新しいウインドを開くのウインドウを...

yoshi - 09/5/22(金) 11:59 -


	引用なし

	パスワード

>メニュー/ウインドウ/整列/左右に並べて表示
>hoge.xls:1，hoge.xls:2
>のようにしているとき
>ブックの×ボタンで閉じられないようにしたいと思っていますが

>Aブック：一般ブック1
>Bブック：一般ブック2
>Cブック：当初コード付ブック

>実際の
>行いたい動作は
>Cブックは2画面表示
>その他のブックが存在しているとき、タスクバーで選択されたときは最大化して表示
>その後、Cブックを選択しても2画面表示
>したいと思っています・・・・

↑の仕様で、ブックの保護(ウィンドウをチェック)を用いると以下のように簡単でしょう。

'ブックモジュール(ThisWorkbook)
Option Explicit

Private Sub Workbook_Activate()
　Unprotect
　Windows.Arrange ArrangeStyle:=xlVertical
　ActiveWindow.Width = ActiveWindow.Width + 2
　Protect Structure:=False, Windows:=True
End Sub

Private Sub Workbook_Deactivate()
　Unprotect
　ActiveWindow.WindowState = xlMaximized
End Sub

Private Sub Workbook_Open()
　If Windows.Count = 1 Then ActiveWindow.NewWindow
　Windows(Name & ":1").Activate
End Sub


	【61690】Re:新しいウインドを開くのウインドウを...

ON - 09/5/27(水) 18:44 -


	引用なし

	パスワード

遅くなりました　申し訳ありません　m(_ _)m
皆様　ありがとうございます

横道にそれますが
周知の事項かも知れませんが・・・下記に気がつきました、

シートにコマンドボタンをはって
新しいウインドウを開いて、並べて表示の状態で
：1、：2どちらでもいいので、コマンドボタンを押すと
アクティブでないシートのコマンドボタンに斜線がかかって
そのボタンは反応しなくなります

斜線がない方のボタンは操作可能です

操作したウィンドウ側をいったん閉じない限りそのウインドウの操作権は
そのまま保持しているようです

>ブックの×ボタンで閉じられないようにしたいと思っていますが
>上記に相当するイベントは無いようです
と、関連があるような気がしますが・・・・

この
>操作したウィンドウ側をいったん閉じない限りそのウインドウ操作権は
>そのまま保持しているようです
は、コード上で初期化？することは出来ますか
あわせて、この状況をググって見たのですが引っ掛けることは出来ませんでした
参考URL等あれば、ご紹介よろしくお願いいたします

本題のほうですが

もやもやと、霧の彼方で、ウインドウのくくりで操作できないものかと思っていたのですが
nさん、yoshiさんから、さくっとその回答が・・・
ありがとうございました　勉強になります

どちらも動作はわかるのですが、自分ではかけないコードです
あわせて、具体的にどこが難しいのかわからないのですが
理解が難しいです

>↑の仕様で、ブックの保護(ウィンドウをチェック)を用いると以下のように簡単でしょう。
ブックの保護(ウィンドウをチェック)だけの違いでないような気もしますが
今回は、yoshiさん　のコードを参考にさせて頂きたいと思います
nさん、申し訳ありません

また
neptuneさんのAPIについては、別途、機会を設けてもう少し勉強したいと思います
申し訳ありませんがよろしくお願いいたします

yoshiさん
>↑の仕様で、
は、
ActiveWindow.Width = ActiveWindow.Width + 2
でなく
.Width = max_w - 142
のように、変数の値でセットしたいのですが

[VBA] Public 宣言された変数の有効期間
ht　tp://support.microsoft.com/default.aspx?scid=kb;ja;408871
のためか
Public 変数の値が破棄されてしまうようなので
　Workbook_Activate
　ToggleButton1_Click
で、各々取得しています

他の変更として

・Workbook_Open時でなく、トグルボタンを設けて、新しいウインドウを開くことにしました
・他に、後2画面表示時、マウスが乗ったウインドウをアクティブにしました
　これは別途、以前webでメモしたものを使用しました（記載先見つかりませんでした）

極力、nさん　の　コードに　近づけたいと思っていましたが
動かすために
Workbook_Open時、Application.EnableEvents = False　とか
ToggleButton1_Click時に、Application.EnableEvents = True　とか
Workbook_Activate時等、変な記述となっています

現状、解決できない問題は
・別ブックを開いて操作すると、2画面表示がうまく機能できなくなってしまいます
・この状態で、ブックを切り替えると、新しいウインドウが作られてしまいます
他にもありそうですが・・・・

これは
>あわせて、具体的にどこが難しいのかわからないのですが
　　　　　~~~~~~~~~~~~~~~~~~~~~~
>理解が難しいです
によるものと思います

解決のためのヒント、アドバイス等あればよろしくお願いいたします

新規ブックの　Sheet1　の　ｂ2あたりにトグルボタンを作成して
下記コード貼れば再現できると思います
よろしくお願いいたします

----------------------------------------------------------------------
'Sheet1モジュール

Option Explicit

Public max_h As Double
Public max_w As Double

Private Sub ToggleButton1_Click()
　　
　　'Stop
　　Application.EnableEvents = True
　　
　　Dim i As Integer
　　Dim ck As Integer
　　
　　ck = 0
　　
　　If Sheet1.ToggleButton1.Value = False Then
　　
　　　　ToggleButton1.Caption = "ＤＴセット(2画面表示)"
　　　　
　　　　del_w
　　　　StopSample
　　　
　　Else
　　　　
　　　　For i = 1 To Windows.Count
　　　　
　　　　　　If ActiveWindow.Caption = ActiveWorkbook.Name & ":1" Then
　　　　　　　　ck = 1
　　　　　　End If
　　　　　　
　　　　Next
　　　　　　
　　　　If ck > 0 Then
　　　　　　Exit Sub
　　　　End If
　　　　
　　　　 ToggleButton1.Caption = "戻　る"
　　　　
　　　　 Unprotect
　　　　
　　　　On Error Resume Next
　　　　　
　　　　 ActiveWindow.NewWindow
　　　　　　
　　　　　　ActiveWindow.WindowState = xlMaximized
　　　　　　max_h = ActiveWindow.Height - 20.25　'なぜか-20.25　必要
　　　　　　max_w = ActiveWindow.Width
　　　　　　
　　　　　 Windows(ActiveWorkbook.Name & ":1").Activate
　　　　　 With ActiveWindow
　　　　　　　 .WindowState = xlNormal　'←元に戻す　と　同等
　　　　　　　 .Top = 0
　　　　　　　 .Left = 0
　　　　　　　 .Height = max_h
　　　　　　　 .Width = 240
　　　　　 End With
　　　　　
　　　　　 'Windows(Name & ":2").Activate
　　　　　 Windows(ActiveWorkbook.Name & ":2").Activate
　　　　　
　　　　　 With ActiveWindow
　　　　　　　 .WindowState = xlNormal
　　　　　　　 .Top = 0
　　　　　　　 .Left = 240
　　　　　　　 .Height = max_h
　　　　　　　 .Width = max_w - 240
　　　　　 End With
　　　　　
　　　　　 ActiveWorkbook.Protect Structure:=False, Windows:=True
　　　　　
　　　　　　Worksheets(2).Select
　　　　
　　　　 On Error GoTo 0
　　　　
　　　　StartSample

　　End If
　　
　　
End Sub

Public Sub del_w()

　　Windows(ActiveWorkbook.Name & ":2").Activate
　　
　　ActiveWorkbook.Unprotect
　　ActiveWindow.Close
　　
　　Windows(ActiveWorkbook.Name).WindowState = xlMaximized

End Sub

----------------------------------------------------------------------
'ThisWorkbookモジュール

Option Explicit

'Public max_h As Double　'標準モジュールでないと保存されない？？？
'Public max_w As Double

Public max_h As Double
Public max_w As Double

Private Sub Workbook_Activate()
　
　
　　Dim i As Integer
　　Dim ck As Integer
　　
　　ck = 0
　　
　　　　For i = 1 To Windows.Count
　　　　
　　　　　　If ActiveWindow.Caption = ActiveWorkbook.Name & ":1" Then
　　　　　　　　ck = 1
　　　　　　End If
　　　　　　
　　　　Next
　　　　　　
　　　　　　
　　　　If ck > 0 Then
　　　　
　　　　　　Exit Sub
　　　　
　　　　End If
　　　　
　　　　 Sheets(1).ToggleButton1.Caption = "戻　る"
　　　　
　　　　 ActiveWindow.NewWindow
　　　　
　　　　 Unprotect
　　　　
　　　　　 On Error Resume Next
　　　　　　
　　　　　 Windows(ActiveWorkbook.Name & ":1").Activate
　　　　　 With ActiveWindow
　　　　　　　 .WindowState = xlNormal　'←元に戻す　と　同等
　　　　　　　 .Top = 0
　　　　　　　 .Left = 0
　　　　　　　 .Height = max_h
　　　　　　　 .Width = 240
　　　　　 End With
　　　　　
　　　　　 Windows(ActiveWorkbook.Name & ":2").Activate
　　　　　
　　　　　 With ActiveWindow
　　　　　　　 .WindowState = xlNormal
　　　　　　　 .Top = 0
　　　　　　　 .Left = 240
　　　　　　　 .Height = max_h
　　　　　 End With
　　　　　
　　　　　 ActiveWorkbook.Protect Structure:=False, Windows:=True
　　　　　
　　　　　　Worksheets(2).Select
　　　　
　　　　 On Error GoTo 0
　　
　
End Sub

Private Sub Workbook_Deactivate()
　Unprotect
　ActiveWindow.WindowState = xlMaximized
End Sub

Private Sub Workbook_Open()

　Application.EnableEvents = False
　
End Sub

----------------------------------------------------------------------

'Module1モジュール

Option Explicit

Private Type POINTAPI
　　x As Long
　　y As Long
End Type
Private Declare Function SetTimer Lib "user32" ( _
　　ByVal Hwnd As Long, ByVal nIDEvent As Long _
　　, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Sub KillTimer Lib "user32" ( _
　　ByVal Hwnd As Long, ByVal nIDEvent As Long)
Private Declare Sub GetCursorPos Lib "user32" ( _
　　lpPoint As POINTAPI)
Private Declare Function WindowFromPoint Lib "user32" ( _
　　ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetParent Lib "user32" ( _
　　ByVal Hwnd As Long) As Long

Private Const ERROR_SUCCESS As Long = 0

Private myTimerId As Long

Sub TimerProc(ByVal Hwnd As Long, ByVal uMsg As Long _
　　, ByVal idEvent As Long, ByVal dwTime As Long)
　　Static myX As Long, myY As Long
　　Dim myPoint As POINTAPI
　　Dim myHwnd As Long
　　GetCursorPos myPoint
　　With myPoint
　　　　If .x = myX And .y = myY Then Exit Sub
　　　　myX = .x: myY = .y
　　End With
　　myHwnd = WindowFromPoint(myX, myY)
　　myHwnd = GetParent(myHwnd)
　　If myHwnd = ERROR_SUCCESS Then Exit Sub
　　myHwnd = GetParent(myHwnd)
　　If myHwnd <> Application.Hwnd Then Exit Sub
　　Debug.Print myX, myY
　　
　　
　　If ActiveWindow.WindowState <> xlMaximized Then
　　
　　　　If myX < 350 Then
　　　　　　On Error Resume Next
　　　　　　Windows(ActiveWorkbook.Name & ":1").Activate
　　　　　　On Error GoTo 0
　　　　Else
　　　　　　On Error Resume Next
　　　　　　Windows(ActiveWorkbook.Name & ":2").Activate
　　　　　　On Error GoTo 0
　　　　End If
　　　　
　　End If
　　
　　
End Sub

Sub StartSample()
　　myTimerId = SetTimer(0&, 0&, 0&, AddressOf TimerProc)
End Sub

Sub StopSample()
　　KillTimer 0&, myTimerId
End Sub


	【61723】Re:新しいウインドを開くのウインドウを...

ON - 09/5/29(金) 21:15 -


	引用なし

	パスワード

訳のわからない投稿申し訳ありませんでした

この辺の処理、トラウマで、いつも、コードが動くように
訳もわからず改変していって？？になってしまいます

基本に戻って、最初から動きを追いかけて下記わかりました
・シートモジュール等のクラスモジュールと標準モジュールでは、name等戻り値が違う
・色々試してみた結果、yoshiさんのコードのように、ウインドウ操作はWorkbook_Activate　のみで行う
・複数ブック使用時で、新しいウインドウを開く場合は、ブックの保護(ウィンドウをチェック)をする

が、基本事項のように思いました

取りあえず、トグルボタンで動作、マウスAPI抜き（組み込んでも動作しました）
コードは、下記で希望の操作かないました
ただ、もっとすっきり書けないものかと思っています

何かアドバイスありましたらよろしくお願いいたします

Sheet1

Option Explicit

Private Sub ToggleButton1_Click()

　　On Error Resume Next
　　'Unprotect
　　ThisWorkbook.Protect Structure:=False, Windows:=True
　　On Error GoTo 0
　　
　　If ToggleButton1.Value = True Then　'2画面表示させる
　　
　　　　ToggleButton1.Caption = "戻　る"
　　
　　　　'If Windows.Count = 1 Then ActiveWindow.NewWindow
　　　　
　　　　'Windows(ThisWorkbook.Name & ":1").Activate
　　　　'↑1ブック時OK、複数ブック時NG　実行時エラー '9':インデックスが有効範囲にありません｡
　　　　
　　　　If Mid(ActiveWindow.Caption, Len(ActiveWindow.Caption) - 1, 1) = ":" Then　　'単独ブック起動時
　　　　
　　　　　　Windows(ThisWorkbook.Name & ":1").Activate
　　　　　　Call ThisWorkbook.Workbook_Activate
　　　　　　
　　　　
　　　　Else　　　'複数ブック起動時
　　　　
　　　　　　ActiveWorkbook.Unprotect
　　　　
　　　　　　ActiveWindow.NewWindow
　　　　
　　　　　　'Windows(ActiveWindow.Caption).Activate
　　　　　　Windows(ThisWorkbook.Name & ":1").Activate
　　　　　　Call ThisWorkbook.Workbook_Activate
　　　　
　　　　End If
　　　　
　　　　
　　Else　　'1画面表示させる（ウィンドウを1つ閉じる）

　　　　ToggleButton1.Caption = "ＤＴセット(2画面表示)"
　　　　
　　　　If Mid(ActiveWindow.Caption, Len(ActiveWindow.Caption) - 1, 1) = ":" Then　　　'単独ブック起動時
　　
　　　　　　Windows(ThisWorkbook.Name & ":2").Activate
　　　　　　'ActiveWorkbook.Unprotect
　　　　　　'ActiveWindow.Close
　　　　　　'ActiveWindow.WindowState = xlMaximized
　　　　　　Call ThisWorkbook.Workbook_Deactivate
　　　　　　
　　　　　　
　　　　Else　　　'複数ブック起動時
　　　　
　　　　　　'Windows(ActiveWindow.Caption).Activate
　　　　　　'ActiveWorkbook.Unprotect
　　　　　　'ActiveWindow.Close
　　　　　　'ActiveWindow.WindowState = xlMaximized
　　　　　　
　　　　　　'On Error Resume Next
　　　　　　Call ThisWorkbook.Workbook_Deactivate
　　　　　　'On Error GoTo 0
　　　　　　
　　　　End If
　　
　　End If

End Sub

ThisWorkbook

Option Explicit

Public max_h As Double
Public max_w As Double

'Private Sub Workbook_Activate()
Public Sub Workbook_Activate()

　　If Mid(ActiveWindow.Caption, Len(ActiveWindow.Caption) - 1, 1) = ":" Then　　 '単独ブック起動時

　　　　Unprotect
　　　　'Windows.Arrange ArrangeStyle:=xlVertical
　　　　'ActiveWindow.Width = ActiveWindow.Width + 2
　　　
　　　　ActiveWindow.WindowState = xlMaximized
　　　　max_h = ActiveWindow.Height - 20.25　'なぜか-20.25　必要
　　　　max_w = ActiveWindow.Width
　　　
　　　　Windows(ActiveWorkbook.Name & ":1").Activate
　　　　With ActiveWindow
　　　　　　.WindowState = xlNormal　'←元に戻す　と　同等
　　　　　　.Top = 0
　　　　　　.Left = 0
　　　　　　.Height = max_h
　　　　　　.Width = 240
　　　　End With
　　
　　　　'Windows(Name & ":2").Activate
　　　　Windows(ActiveWorkbook.Name & ":2").Activate
　　
　　　　With ActiveWindow
　　　　　　.WindowState = xlNormal
　　　　　　.Top = 0
　　　　　　.Left = 240
　　　　　　.Height = max_h
　　　　　　.Width = max_w - 240
　　　　End With
　　
　　　　ActiveWorkbook.Protect Structure:=False, Windows:=True
　　　　
　　　　Sheets(2).Select
　　　　
　　End If
　
　
　　'Protect Structure:=False, Windows:=True
　
End Sub

'Private Sub Workbook_Deactivate()
Public Sub Workbook_Deactivate()

　Unprotect

　On Error Resume Next
　Windows(Me.Name & ":2").Close
　On Error GoTo 0
　
　On Error Resume Next
　ActiveWindow.WindowState = xlMaximized
　On Error GoTo 0
　
End Sub

Private Sub Workbook_WindowActivate(ByVal Wn As Window)

　　'MsgBox Application.Caption & ActiveWindow.Caption
　　'ウインドウ切替時、単独ブックだったら最大化表示
　　If Mid(ActiveWindow.Caption, Len(ActiveWindow.Caption) - 1, 1) <> ":" Then　　'単独ブック起動時
　　
　　　　Unprotect
　　　　ActiveWindow.WindowState = xlMaximized
　　
　　End If

End Sub


	【61737】Re:新しいウインドを開くのウインドウを...

yoshi - 09/5/30(土) 16:19 -


	引用なし

	パスワード

>シートにコマンドボタンをはって
>新しいウインドウを開いて、並べて表示の状態で
>：1、：2どちらでもいいので、コマンドボタンを押すと
>アクティブでないシートのコマンドボタンに斜線がかかって
>そのボタンは反応しなくなります

コントロールツールボックスではそうなるようです。
色々問題のあるコントロールなので、昔ながらのフォームのボタンを使われたらどうでしょう。

>取りあえず、トグルボタンで動作、マウスAPI抜き（組み込んでも動作しました）
>コードは、下記で希望の操作かないました
>ただ、もっとすっきり書けないものかと思っています

そうですね...
以下のかんじくらいにはなると思います。

'ブックモジュール(ThisWorkbook)
Option Explicit

Private Sub Workbook_Activate()
　Dim wn As Window, aw As Window
　Set aw = ActiveWindow
　If ActiveWorkbook.Windows.Count > 1 Then
　　For Each wn In ActiveWorkbook.Windows
　　　wn.Activate
　　Next
　　aw.Activate
　End If
End Sub

Private Sub Workbook_Deactivate()
　ActiveWindow.WindowState = xlMaximized
End Sub

'Sheet1モジュール
Option Explicit

Private Sub ToggleButton1_Click()
　Dim ww!
　'If ToggleButton1.Value = True Then
　If ActiveWorkbook.Windows.Count = 1 Then
　　ToggleButton1.Caption = "戻　る"
　　Parent.Unprotect
　　ActiveWindow.NewWindow
　　With Windows(Parent.Name & ":1")
　　　.Activate
　　　ActiveWorkbook.Windows.Arrange ArrangeStyle:=xlVertical
　　　ww = .Width + 2 - 240
　　　.Width = 240
　　End With
　　With Windows(Parent.Name & ":2")
　　　.Activate
　　　.Left = .Left - ww: .Width = .Width + ww
　　End With
　　Sheets("Sheet2").Select
　　Parent.Protect Structure:=False, Windows:=True
　Else
　　ToggleButton1.Caption = "ＤＴセット(2画面表示)"
　　Parent.Unprotect
　　Windows(Parent.Name & ":2").Close
　　ActiveWindow.WindowState = xlMaximized
　End If
End Sub


	【61804】Re:新しいウインドを開くのウインドウを...

ＯＮ - 09/6/5(金) 16:17 -


	引用なし

	パスワード

大変遅くなりました　m(_ _)m

解説、添削ありがとうございます

>コントロールツールボックスではそうなるようです。
>色々問題のあるコントロールなので、昔ながらのフォームのボタンを使われたらどうでしょう。
普段、VBのツールバーを表示しているので、これを使用していました
フォームのコントロールはあまり使用したことはないです
ただ、こちらには、トグルボタンはありました
どうするか、もう少し検討してみます

>以下のかんじくらいにはなると思います。
コードのご提示ありがとうございます
全然、違いますね、1/4ぐらいになっているし・・・

Parentあまり使用したことはありません
また、自分の理解が足りていないことが原因で無駄が多いこと理解できました
ありがとうございました

>取りあえず、トグルボタンで動作、マウスAPI抜き（組み込んでも動作しました）
>コードは、下記で希望の操作かないました
は勘違いでした
別ブックを起動すると、マウス移動でのウインドウの切り替えは出来なくなりました

yoshiさんのコードにマウスのAPIを追加してみましたが
やはり、別ブックを起動すると、
マウス移動でのウインドウの切り替えは出来なくなりました

そこで、色々、StartSample、StopSampleを散りばめて記述してみましたが　(*o*)＼baki
うまく出来ませんでした

つらつら思うに、別ブックの起動を含めた制御を行うには
アプリケーションレベルでの制御が必要になると思い
理解が乏しくあまり使用したことがないのですが下記のクラスを使用してみました

------------------------------------------------------
'Class1

Option Explicit

Public WithEvents appevent As Application

Private Sub appevent_WindowActivate(ByVal Wb As Workbook, ByVal Wn As Window)
　　
　　 'MsgBox ActiveWindow.Caption
　　 'MsgBox Parent.Caption
　　
　　 If Mid(ActiveWindow.Caption, Len(ActiveWindow.Caption) - 1, 1) = ":" Then
　　　　MsgBox ActiveWindow.Caption
　　 End If
　　
End Sub

------------------------------------------------------
'Module1

Option Explicit

　　　Dim myobject As New Class1

　　　Sub Test()
　　　　　Set myobject.appevent = Application
　　　End Sub

Testを実行すると、複数ブック、複数ウインドウを開いて
マウスでブックを選んだとき、タスクバーで選択したときとか
タイトルバーのキャプションをメッセージ出来ました

>>この辺の処理、トラウマで、いつも、コードが動くように
>>訳もわからず改変していって？？になってしまいます
ウインドウズの操作が苦手（いつも？？）で闇雲コードとなっていましたが
これと、APIでHwndが扱えれば、かなりのことが出来そうな気がしてきました
↑
気がしているだけですが・・・

ここまでの理解で下記してみましたが
他ブック選択後、2画面ブックにもどってマウスでウインドウの切り替えは出来ませんでした

Private Sub appevent_WindowActivate(ByVal Wb As Workbook, ByVal Wn As Window)
　　
　　 'MsgBox ActiveWindow.Caption
　　 'MsgBox Parent.Caption
　　
　　 If Mid(ActiveWindow.Caption, Len(ActiveWindow.Caption) - 1, 1) = ":" Then
　　　　'MsgBox ActiveWindow.Caption
　　　　mouse_monitore_Start
　　 Else
　　　　mouse_monitore_Stop
　　　　
　　 End If
　　
End Sub

TimerProcが理解できていないためのような気もしますが
上記アプローチが悪いためかもしれません

アドバイス頂けるとうれしいです

よろしくお願いいたします


	【61808】Re:新しいウインドを開くのウインドウを...

yoshi - 09/6/5(金) 18:17 -


	引用なし

	パスワード

>>取りあえず、トグルボタンで動作、マウスAPI抜き（組み込んでも動作しました）
>>コードは、下記で希望の操作かないました
>は勘違いでした
>別ブックを起動すると、マウス移動でのウインドウの切り替えは出来なくなりました

どういう不都合が出ているのか、どうしたいのか↑の説明ではさっぱり分かりません。
09/5/30(土) 16:19 ←に示したマクロで、複数ブックを開いても、それぞれウィンドウの切替は出来ましたけど...
タスクバーのクリックでも、メニューのウィンドウからの切替でも出来ました。


	【61809】Re:新しいウインドを開くのウインドウを...

ＯＮ - 09/6/5(金) 19:10 -


	引用なし

	パスワード

▼yoshi さん：
>どういう不都合が出ているのか、どうしたいのか↑の説明ではさっぱり分かりません。
>09/5/30(土) 16:19 ←に示したマクロで、複数ブックを開いても、それぞれウィンドウの切替は出来ましたけど...
>タスクバーのクリックでも、メニューのウィンドウからの切替でも出来ました。

お手数かけます　よろしくお願い致します
以下のようにしてみました

新規ブック開く
上記にコード貼り付け、トグルボタン追加
エクセル保存、終了
上記起動

トグルボタン　実行
マウス移動でウインドウの切替動作　良好
ファイル開くで、新規ブック作成
新規ブックが全画面で表示
タスクバーで、マクロブック選択
マクロブック2画面で表示される
マウス移動で、2画面の切替が出来ない
VBEの画面を見てみると、VBEのタイトルバーがちかちかしている
Module1　mouse_monitore_Stop　を実行すると　VBEのタイトルバーがちかちかが停止

上記で
マクロブック2画面で表示される
マウス移動で、2画面の切替が出来ない
↑
マウス移動で、アクティブウインドウの切替が出来ないものかと思っています

よろしくお願い致します

貼り付けコード
--------------------------------------------------------
'Sheet1モジュール
Option Explicit

Private Sub ToggleButton1_Click()
　Dim ww!
　'If ToggleButton1.Value = True Then
　If ActiveWorkbook.Windows.Count = 1 Then
　　ToggleButton1.Caption = "戻　る"
　　Parent.Unprotect
　　ActiveWindow.NewWindow
　　With Windows(Parent.Name & ":1")
　　　.Activate
　　　ActiveWorkbook.Windows.Arrange ArrangeStyle:=xlVertical
　　　ww = .Width + 2 - 240
　　　.Width = 240
　　End With
　　With Windows(Parent.Name & ":2")
　　　.Activate
　　　.Left = .Left - ww: .Width = .Width + ww
　　End With
　　Sheets("Sheet2").Select
　　Parent.Protect Structure:=False, Windows:=True
　　
　　mouse_monitore_Start
　　
　Else
　　ToggleButton1.Caption = "ＤＴセット(2画面表示)"
　　Parent.Unprotect
　　Windows(Parent.Name & ":2").Close
　　ActiveWindow.WindowState = xlMaximized
　　
　　mouse_monitore_Stop
　　
　　
　End If
End Sub

--------------------------------------------------------
'ThisWorkbook

'ブックモジュール(ThisWorkbook)
Option Explicit

Private Sub Workbook_Activate()
　Dim wn As Window, aw As Window
　Set aw = ActiveWindow
　If ActiveWorkbook.Windows.Count > 1 Then
　　For Each wn In ActiveWorkbook.Windows
　　　wn.Activate
　　Next
　　aw.Activate
　End If
End Sub

Private Sub Workbook_Deactivate()
　ActiveWindow.WindowState = xlMaximized
End Sub

--------------------------------------------------------
'Module1

'Module1モジュール

Option Explicit

Private Type POINTAPI
　　x As Long
　　y As Long
End Type
Private Declare Function SetTimer Lib "user32" ( _
　　ByVal Hwnd As Long, ByVal nIDEvent As Long _
　　, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Sub KillTimer Lib "user32" ( _
　　ByVal Hwnd As Long, ByVal nIDEvent As Long)
Private Declare Sub GetCursorPos Lib "user32" ( _
　　lpPoint As POINTAPI)
Private Declare Function WindowFromPoint Lib "user32" ( _
　　ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetParent Lib "user32" ( _
　　ByVal Hwnd As Long) As Long

Private Const ERROR_SUCCESS As Long = 0

Private myTimerId As Long

Sub TimerProc(ByVal Hwnd As Long, ByVal uMsg As Long _
　　, ByVal idEvent As Long, ByVal dwTime As Long)
　　Static myX As Long, myY As Long
　　Dim myPoint As POINTAPI
　　Dim myHwnd As Long
　　GetCursorPos myPoint
　　With myPoint
　　　　If .x = myX And .y = myY Then Exit Sub
　　　　myX = .x: myY = .y
　　End With
　　myHwnd = WindowFromPoint(myX, myY)
　　myHwnd = GetParent(myHwnd)
　　If myHwnd = ERROR_SUCCESS Then Exit Sub
　　myHwnd = GetParent(myHwnd)
　　If myHwnd <> Application.Hwnd Then Exit Sub
　　Debug.Print myX, myY
　
　
　　If ActiveWindow.WindowState <> xlMaximized Then
　
　　　　If myX < 350 Then
　　　　　　On Error Resume Next
　　　　　　Windows(ActiveWorkbook.Name & ":1").Activate
　　　　　　On Error GoTo 0
　　　　Else
　　　　　　On Error Resume Next
　　　　　　Windows(ActiveWorkbook.Name & ":2").Activate
　　　　　　On Error GoTo 0
　　　　End If
　　
　　End If
　
　
End Sub

Sub mouse_monitore_Start()
　　myTimerId = SetTimer(0&, 0&, 0&, AddressOf TimerProc)
End Sub

Sub mouse_monitore_Stop()
　　KillTimer 0&, myTimerId
End Sub


	【61817】Re:新しいウインドを開くのウインドウを...

yoshi - 09/6/6(土) 16:54 -


	引用なし

	パスワード

▼ＯＮさん：
>上記で
>マクロブック2画面で表示される
>マウス移動で、2画面の切替が出来ない
>↑
>マウス移動で、アクティブウインドウの切替が出来ないものかと思っています

マウスカーソルの移動でウィンドウの切替えを行うということですか。
違和感のあるUIのような気がします。
通常、ウィンドウ整列した状態ではマウスカーソルに合わせてウィンドウが切替わらないので...

それはさておき、うまくいかない点についてですが...
なんかロジックが雑多で確実性に欠けてるように思います。
簡潔にちょっと直してみました。

'ブックモジュール(ThisWorkbook)
Option Explicit

Private Sub Workbook_Activate()
　Dim wn As Window, aw As Window
　Set aw = ActiveWindow
　If ActiveWorkbook.Windows.Count > 1 Then
　　For Each wn In ActiveWorkbook.Windows
　　　wn.Activate
　　Next
　　aw.Activate
　　mouse_monitore_Start
　End If
End Sub

Private Sub Workbook_Deactivate()
　ActiveWindow.WindowState = xlMaximized
　mouse_monitore_Stop
End Sub

'Sheet1モジュール
Option Explicit

Private Sub ToggleButton1_Click()
　Dim ww!
　'If ToggleButton1.Value = True Then
　If ActiveWorkbook.Windows.Count = 1 Then
　　ToggleButton1.Caption = "戻　る"
　　Parent.Unprotect
　　ActiveWindow.NewWindow
　　With Windows(Parent.Name & ":1")
　　　.Activate
　　　ActiveWorkbook.Windows.Arrange ArrangeStyle:=xlVertical
　　　ww = .Width + 2 - 240
　　　.Width = 240
　　End With
　　With Windows(Parent.Name & ":2")
　　　.Activate
　　　.Left = .Left - ww: .Width = .Width + ww
　　End With
　　Sheets("Sheet2").Select
　　Parent.Protect Structure:=False, Windows:=True
　　mouse_monitore_Start
　Else
　　ToggleButton1.Caption = "ＤＴセット(2画面表示)"
　　Parent.Unprotect
　　Windows(Parent.Name & ":2").Close
　　ActiveWindow.WindowState = xlMaximized
　　mouse_monitore_Stop
　End If
End Sub

'標準モジュール
Option Explicit
Private Type POINTAPI
　x As Long
　y As Long
End Type
Private Declare Function SetTimer Lib "user32" ( _
　ByVal hWnd As Long, ByVal nIDEvent As Long _
　, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Sub KillTimer Lib "user32" ( _
　ByVal hWnd As Long, ByVal nIDEvent As Long)
Private Declare Sub GetCursorPos Lib "user32" ( _
　lpPoint As POINTAPI)
Private Declare Function WindowFromPoint Lib "user32" ( _
　ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Sub GetWindowText Lib "user32" Alias "GetWindowTextA" _
　(ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long)
Private TimerId As Long

Sub TimerProc(ByVal hWnd As Long, ByVal uMsg As Long _
　, ByVal idEvent As Long, ByVal dwTime As Long)
　On Error Resume Next
　If Not ThisWorkbook Is ActiveWorkbook Then KillTimer 0, idEvent
　Dim Point As POINTAPI, Caption$
　GetCursorPos Point
　hWnd = WindowFromPoint(Point.x, Point.y)
　If hWnd = 0 Then Exit Sub
　Caption = String(256, vbNullChar)
　GetWindowText hWnd, Caption, Len(Caption)
　Caption = Left$(Caption, InStr(Caption, vbNullChar) - 1)
　If Caption = "" Then Exit Sub
　If Mid(Caption, Len(Caption) - 1, 1) <> ":" Then Exit Sub
　If ActiveWindow.Caption <> Caption Then Windows(Caption).Activate
End Sub

Sub mouse_monitore_Start()
　If TimerId Then mouse_monitore_Stop
　TimerId = SetTimer(0&, 0&, 0&, AddressOf TimerProc)
End Sub

Sub mouse_monitore_Stop()
　If TimerId Then KillTimer 0&, TimerId
　TimerId = 0
End Sub


	【61930】Re:新しいウインドを開くのウインドウを...

ON - 09/6/12(金) 16:36 -


	引用なし

	パスワード

大変遅くなりました
yoshiさん　ありがとうございます

長いので　投稿を3回に分けました

>マウスカーソルの移動でウィンドウの切替えを行うということですか。
>違和感のあるUIのような気がします。
>通常、ウィンドウ整列した状態ではマウスカーソルに合わせてウィンドウが切替わらないので…

>それはさておき、うまくいかない点についてですが…
>なんかロジックが雑多で確実性に欠けてるように思います。
>簡潔にちょっと直してみました。
ありがとうございました
希望の動作かないました

実際に動かしてみると、やはり使い辛い面がありますね

やりたかったことは
フォームやプルダウン等からの入力補助みたいなものは作成したことがあったのですが
複数の表から選択（表シートも多有り）するような場合、シートを2つ並べて
入力したほうが利用しやすいような気がしていました
今回、そんな状況もあったので、試しに作成してみました
左シート：シート選択　および　選択データ書き込み
右シート：　表より選択
左シートのデータを元に各帳票作成みたいな・・・

わかりにくいと思うので、動作確認用マクロつけました
よろしければ動かしてみてください
モニタ17-19インチで表示のイメージです

新規ブックに、コードをコピー後
Module2　の　SET_V()　実行
シート1の右のトグルボタンを押し、2画表示
右シートの表を左からwクリックで選択すると
　単一選択項目は背景色が水色
　複数選択項目は背景色が緑色
　最終項目を選択すると背景色が橙色　となります
　この時、右シートの表示外S、T列に選択値が記載されます
また、上位項目からの再選択が可能です

想像していたよりか利用しにくいみたいな感じで・・(~_~;)

で、下記2点アドバイスあればよろしくお願いたします
>　この時、右シートの表示外S、T列に選択値が記載されます
を、
>左シート：シート選択　および　選択データ書き込み
したいと思っているのですが

Sub GET_dt()

　　Dim myRange As Range　　

　　　　For Each myRange In ActiveSheet.Range("T13:T23")
　　　　
　　　　　 If myRange.Value > 0 Then
　　　　　　　
　　　 '　　　 Sheets(4).Range(Cells(myRange.Row, 19), Cells(myRange.Row, 20)).Select
　　　 '　　　 Sheets(4).Range(Cells(myRange.Row, 19), Cells(myRange.Row, 20)).Copy
　　　　　　　Sheets(4).Range("S18:T18").Copy
　　　　　　　
　　　　　　　
　　　　　　　Windows("hoge.xls:1").Activate
　　　　　　　　　　　　　　
　　　　　　　 'Sheets(1).Range(Cells(23, 3), Cells(24, 3)).Select
　　　　　　　　　　　 'Sheets(1).Range(Cells(23, 3), Cells(24, 3)).Paste
　　　　　　　　　　　
　　　　　　　　 'ActiveWindow.Parent.Sheets(1).Range(Cells(23, 3), Cells(24, 3)).Select
　　　　　　 '　　ActiveWindow.Parent.Sheets(1).Range("C23:D23").Select
　　　　　　'　　 Selection.Paste

　　　　　　　　ActiveWindow.Parent.Sheets(1).Range("C23:D23").Select
　　　　　　　　ActiveWindow.Parent.Sheets(1).Range("C23:D23").Paste　'←エラー
　　　　　　
　　　　　　　　MsgBox ""
　　　　　　　　Exit Sub
　　　　　　　
　　　　　 End If
　　　　Next myRange

End Sub

オブジェクトは、このプロパティまたはメソッドをサポートしていません。
となってしまいます
ここで、シートをアクティブにして、Ctrl+Vでは張り付きます・・・・
色々試しましたが、上記までしか辿りつけませんでした

アドバイスあればよろしくお願いいたします

また
>>この辺の処理、トラウマで、いつも、コードが動くように
>>訳もわからず改変していって？？になってしまいます
の典型みたいな記述が
Sheet2　の　表操作コードです

何とか希望の操作で動いていますが・・・・
自分で読み返すのいやなほどなので、見ていただくつもりはないのですが
再度書き直してもそれほど代わり映えしないような気がしています

一応の方針としては
レイアウトの変更等があっても
Sheet2モジュール
　　　　　　　　'行範囲指定で、表の列範囲を設定
　　　　　　　　Select Case ActiveCell.Row
　　　　　　　　　　Case 13 To 23　 '表1
　　　　　　　　　　　　bk_c = 34
　　　　　　　　　　　　Call Me.MTRX_add_color(TGH_R_S, TGH_R_E, 1, 16, ActiveCell.Cells.Column)
のようにして設定することで
修正がないようにとしていますが・・・・・

全体的にこんな動作自体がばかげているような気もしますが
コードの作成の方向性とかありましたら
アドバイスあればよろしくお願いいたします

以下　コード
-------------------------------------------------

/////////////////////////////////////////////////////////////
'Sheet1

Option Explicit

Private Sub ToggleButton1_Click()
　Dim ww!
　'If ToggleButton1.Value = True Then
　If ActiveWorkbook.Windows.Count = 1 Then
　
　　Application.ScreenUpdating = False
　　Sheet1.ToggleButton1.Caption = "戻る（１画面表示面）"　'戻　る）　→　戻る（１画面表示）
　　Sheet1.ToggleButton2.Caption = "非連動"　　　'20090608
　　
　　Parent.Unprotect
　　ActiveWindow.NewWindow
　　With Windows(Parent.Name & ":1")
　　　.Activate
　　　ActiveWorkbook.Windows.Arrange ArrangeStyle:=xlVertical
　　　'ww = .Width + 2 - 240
　　　'.Width = 240
　　　ww = .Width + 2 - 190
　　　.Width = 190　　　
　　End With
　　With Windows(Parent.Name & ":2")
　　　.Activate
　　　.Left = .Left - ww: .Width = .Width + ww
　　End With
　　Sheets(2).Select
　　Parent.Protect Structure:=False, Windows:=True
　　
　　Sheet1.ToggleButton2.Visible = True
　　'Sheet1.CommandButton2.Visible = True
　　
'　　mouse_monitore_Start　　　'連動トグルボタンに移動
　　
　　If Sheet1.ToggleButton2.Value = True Then
　　　　mouse_monitore_Start
　　
　　ElseIf Sheet1.ToggleButton2.Value = False Then
　　　　mouse_monitore_Stop　　
　　End If　　　　
　　
'　　Sheet1.ToggleButton2.Value = True
'　　Application.ScreenUpdating = True
　　
　Else
　
　　Application.ScreenUpdating = False
　　
　　Sheet1.ToggleButton1.Caption = "ＤＴセット(2画面表示)"
　　Parent.Unprotect
　　Windows(Parent.Name & ":2").Close
　　ActiveWindow.WindowState = xlMaximized
　　'mouse_monitore_Stop　　　'連動トグルボタンに移動
　　Sheet1.ToggleButton2.Visible = False
　　'Sheet1.CommandButton2.Visible = False
　　
　　Application.ScreenUpdating = True
　　
　End If
End Sub

Private Sub ToggleButton2_Click()

　　If Sheet1.ToggleButton2.Caption = "非連動" Then　　
　　　　Sheet1.ToggleButton2.Caption = "連動"
　　　　Sheet1.ToggleButton2.Value = False
　　　　mouse_monitore_Stop
　　ElseIf ToggleButton2.Caption = "連動" Then　　
　　　　Sheet1.ToggleButton2.Caption = "非連動"
　　　　Sheet1.ToggleButton2.Value = True
　　　　mouse_monitore_Start
　　End If

End Sub

/////////////////////////////////////////////////////////////
'ThisWorkbook

Option Explicit

Private Sub Workbook_Activate()
　Dim wn As Window, aw As Window
　Set aw = ActiveWindow
　If ActiveWorkbook.Windows.Count > 1 Then
　　For Each wn In ActiveWorkbook.Windows
　　　wn.Activate
　　Next
　　aw.Activate
　　
　　'MsgBox ActiveWindow.Caption
　　
　　If ActiveWindow.Caption <> "" And Sheet1.ToggleButton2.Caption = "非連動" Then
　　　　mouse_monitore_Start
　　
　　End If
　　
　　
　End If
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)

　　mouse_monitore_Stop

End Sub

Private Sub Workbook_Deactivate()

　ActiveWindow.WindowState = xlMaximized
　

End Sub

/////////////////////////////////////////////////////////////
'Module1

'マウス監視　で　ウィンドウをアクティブにする

Option Explicit

Private Type POINTAPI
　x As Long
　y As Long
End Type
Private Declare Function SetTimer Lib "user32" ( _
　ByVal hWnd As Long, ByVal nIDEvent As Long _
　, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Sub KillTimer Lib "user32" ( _
　ByVal hWnd As Long, ByVal nIDEvent As Long)
Private Declare Sub GetCursorPos Lib "user32" ( _
　lpPoint As POINTAPI)
Private Declare Function WindowFromPoint Lib "user32" ( _
　ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Sub GetWindowText Lib "user32" Alias "GetWindowTextA" _
　(ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long)
Private TimerId As Long

Sub TimerProc(ByVal hWnd As Long, ByVal uMsg As Long _
　, ByVal idEvent As Long, ByVal dwTime As Long)
　On Error Resume Next
　If Not ThisWorkbook Is ActiveWorkbook Then KillTimer 0, idEvent
　Dim Point As POINTAPI, Caption$
　GetCursorPos Point
　hWnd = WindowFromPoint(Point.x, Point.y)
　If hWnd = 0 Then Exit Sub
　Caption = String(256, vbNullChar)
　GetWindowText hWnd, Caption, Len(Caption)
　Caption = Left$(Caption, InStr(Caption, vbNullChar) - 1)
　If Caption = "" Then Exit Sub
　If Mid(Caption, Len(Caption) - 1, 1) <> ":" Then Exit Sub
　If ActiveWindow.Caption <> Caption Then Windows(Caption).Activate
End Sub

Sub mouse_monitore_Start()
　If TimerId Then mouse_monitore_Stop
　TimerId = SetTimer(0&, 0&, 0&, AddressOf TimerProc)
End Sub

Sub mouse_monitore_Stop()
　If TimerId Then KillTimer 0&, TimerId
　TimerId = 0
End Sub

/////////////////////////////////////////////////////////////
'Module2

Option Explicit

Sub SET_V()

　　MK_TGL

　　Cells.UnMerge
　　CELL_Merge1
　　CELL_Merge2
　　
　　
　　Sheets("Sheet2").Select
　　Range("A13:Q32").Select
　　With Selection.Borders
　　　　.LineStyle = xlContinuous
　　　　.Weight = xlThin
　　End With
　　Range("A13:A23").Select
　　
　　Sheets("Sheet1").Select

End Sub

Public Sub MK_TGL()

　　Sheets(1).OLEObjects.Add _
　　　　ClassType:="Forms.ToggleButton.1", Link:=False, _
　　　　　　DisplayAsIcon:=False, Left:=71.25, Top:=11.25, Width:=87.75, Height:=18
　　
　　Sheets(1).OLEObjects.Add _
　　　　ClassType:="Forms.ToggleButton.1", Link:=False, _
　　　　　　DisplayAsIcon:=False, Left:=9, Top:=11.25, Width:=50.25, Height:=18
　　　　　　
　　Sheets(1).Select
　　Range("A6").FormulaR1C1 = "13"
　　Range("A7").FormulaR1C1 = "24"
　　Range("A7").AutoFill Destination:=Range("A7:A15"), Type:=xlFillSeries

End Sub

Sub CELL_Merge1()
Sheets(2).Range("" & _
"A13:A23,A24:B28,A29:B32," & _
"B13:B17,B18:B23,C13:F17," & _
"C18:F23,C24:Q24,C25:Q25," & _
"C26:Q26,C27:F28,C29:Q29," & _
"C30:Q30,C31:F32,G13:G16," & _
"G17:K17,G18:G21,G22:K22," & _
"G23:K23,G27:Q27,G28:Q28," & _
"G31:Q31,G32:Q32,H13:K13" & _
"").Merge
End Sub

Sub CELL_Merge2()
Sheets(2).Range("" & _
"H14:K14,H15:K15,H16:K16," & _
"H18:K18,H19:K19,H20:K20," & _
"H21:K21,L13:Q13,L14:Q14," & _
"L15:Q15,L16:Q16,L17:Q17," & _
"L18:Q18,L19:Q19,L20:Q20," & _
"L21:Q21,L22:Q22,L23:Q23" & _
"").Merge
End Sub


	【61931】Re:新しいウインドを開くのウインドウを...

ON - 09/6/12(金) 16:37 -


	引用なし

	パスワード

/////////////////////////////////////////////////////////////
'Sheet2

Option Explicit

'当該シート上では、行挿入等でもマクロは動くが、
'Targetの編集は、Case　Target　のモジュール修正必須
'また、サブプロシージャで、セル指定等している場合は修正が発生することもある

'表範囲指定
Dim mrs As Long　　'表開始行
Dim mre As Long　　'表最終行
Dim mcs As Long　　'表開始列
Dim mce As Long　　'表最終列
Dim tg_col As Long 'tg指定行

Dim bk_c As Long　 'セル背景色

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

　　Dim TGH_R_S
　　Dim TGH_R_E
　　
　　TGH_R_S = Target.Row　　　　　　　　　　　　　　'選択セルの行番
　　TGH_R_E = TGH_R_S + Target.Rows.Count - 1　　　 '選択セルが結合セルのときは最後の行番
　　　　
　　If ActiveCell.Row >= 13 Then
　　
　　　　'選択セルが色つきの時
　　　　If ActiveCell.Interior.ColorIndex <> -4142 Then
　　　　
　　　　　　If MsgBox("再選択しますか", vbOKCancel) = vbOK Then
　　　　　　　　
　　　　　　　　'表の　列番範囲指定　固定値、行番範囲指定　選択セルの行範囲
　　　　　　　　'Call Sheet12.MTRX_clear_color(TGH_R_S, TGH_R_E, 1, 16, ActiveCell.Cells.Column)
　　　　　　　　
　　　　　　　　'複数選択制御値クリア　　　'＄＄＄＄＄＄＄＄＄＄＄＄＄＄＄＄　　　　　　　　
　　　　　　　　
　　　　　　　　If ActiveCell.Interior.ColorIndex = 34 Then　　'複数選択駄目
　　　　　　　　
　　　　　　　　　　'選択セルの右セル背景色クリア
　　　　　　　　　　Call Me.MTRX_clear_color(TGH_R_S, TGH_R_E, 1, 16, ActiveCell.Cells.Column)
　　　　　　　　
　　　　　　　　　　Range(Cells(Cells(ActiveCell.Row, 1).MergeArea.Row, 19), Cells(Cells(ActiveCell.Row, 1).MergeArea.Row + Cells(ActiveCell.Row, 1).MergeArea.Rows.Count - 1, 19)).FormulaR1C1 = ""
　　　　　　　　　　Range(Cells(Cells(ActiveCell.Row, 1).MergeArea.Row, 20), Cells(Cells(ActiveCell.Row, 1).MergeArea.Row + Cells(ActiveCell.Row, 1).MergeArea.Rows.Count - 1, 20)).FormulaR1C1 = ""
　　　　　　　　
　　　　　　　　ElseIf ActiveCell.Interior.ColorIndex = 43 Then　'複数選択ＯＫ　　　'24-28　不具合　！！！！　20090611　ｎｎｎｎｎｎｎｎｎｎｎｎｎｎｎｎｎｎｎｎｎ
　　　　　　　　
　　　　　　　　　　'MsgBox ""　　　　　　　　　　
　　　　　　　　　　'選択セルの右セル背景色クリア
　　　　　　　　　　Call Me.MTRX_clear_color(TGH_R_S, TGH_R_E, 1, 16, ActiveCell.Cells.Column)
　　　　　　　　　　
　　　　　　　　　　'Range(Cells(Cells(ActiveCell.Row, 1).MergeArea.Row, 20), Cells(Cells(ActiveCell.Row, 1).MergeArea.Row + Cells(ActiveCell.Row, 1).MergeArea.Rows.Count - 1, 20)).FormulaR1C1 = ""
　　　　　　　　　　'YYYY
　　　　　　　　　　If ActiveCell.Column = 1 Then
　　　　　　　　　　
　　　　　　　　　　　　'Range(Cells(Cells(ActiveCell.Row, ActiveCell.Column).MergeArea.Row, 20), Cells(Cells(ActiveCell.Row, 1).MergeArea.Row + Cells(ActiveCell.Row, 1).MergeArea.Rows.Count - 1, 20)).Select
　　　　　　　　　　　　'Range(Cells(Cells(ActiveCell.Row, ActiveCell.Column).MergeArea.Row, 19), Cells(Cells(ActiveCell.Row, 1).MergeArea.Row + Cells(ActiveCell.Row, 1).MergeArea.Rows.Count - 1, 19)).FormulaR1C1 = ""
　　　　　　　　　　　　Range(Cells(Cells(ActiveCell.Row, ActiveCell.Column).MergeArea.Row, 20), Cells(Cells(ActiveCell.Row, 1).MergeArea.Row + Cells(ActiveCell.Row, 1).MergeArea.Rows.Count - 1, 19)).FormulaR1C1 = ""
　　　　　　　　　　　　Range(Cells(Cells(ActiveCell.Row, ActiveCell.Column).MergeArea.Row, 20), Cells(Cells(ActiveCell.Row, 1).MergeArea.Row + Cells(ActiveCell.Row, 1).MergeArea.Rows.Count - 1, 20)).FormulaR1C1 = ""
　　　　　　　　　　
　　　　　　　　　　ElseIf ActiveCell.Column > 1 Then　　　　　　　　　　　　
　　　　　　　　　　　　'MsgBox "> 1"　　'この辺　不具合あり　！！！！　　　　　　　　　　　　
　　　　　　　　　　　　Range(Cells(Cells(ActiveCell.Row, ActiveCell.Column).MergeArea.Row, 20), Cells(Cells(ActiveCell.Row, 1).MergeArea.Row + Cells(ActiveCell.Row, 1).MergeArea.Rows.Count - 1, 20)).FormulaR1C1 = ""
　　　　　　　　　　　　　　　　　　　　　　
　　　　　　　　　　'ElseIf ActiveCell.Column = 1 Then　　　　　　　　　　
　　　　　　　　　　'　　MsgBox "="　　　　　　　　　　　　
　　　　　　　　　　Else　　　　　　　　　　
　　　　　　　　　　End If
　　　　　　　　　　
　　　　　　　　ElseIf ActiveCell.Interior.ColorIndex = 40 Then
　　　　　　　　
　　　　　　　　　　ActiveCell.Interior.ColorIndex = -4142
　　　　　　　　　　'Range(Cells(Cells(ActiveCell.Row, 1).MergeArea.Row, 20), Cells(Cells(ActiveCell.Row, 1).MergeArea.Row + Cells(ActiveCell.Row, 1).MergeArea.Rows.Count - 1, 20)).FormulaR1C1 = ""
　　 '＆＆　　　　　　　 Range(Cells(Cells(ActiveCell.Row, 1).MergeArea.Row, 19), Cells(Cells(ActiveCell.Row, 1).MergeArea.Row + Cells(ActiveCell.Row, 1).MergeArea.Rows.Count - 1, 19)).FormulaR1C1 = ""
　　　　　　　　　　Cells(ActiveCell.Row, 20).FormulaR1C1 = ""　　　　　　　　
　　　　　　　　End If　　　　　　　　
　　　　　　Else
　　　　　　　　'（キャンセルボタンが押されたとき）
　　　　　　End If
　　　　　　
　　　　　　
　　　　'選択セルが色無し時
　　　　Else
　　　　　　
　　　　　　'前列　左側セルが選択済みかチェック
　　　　　　If ck_Before_color = 1 Then
　　　　　　
　　　　　　　　'Call Sheet12.MTRX_add_color(TGH_R_S, TGH_R_E, 1, 16, ActiveCell.Cells.Column)
　　　　　　　　'Call Me.MTRX_add_color(TGH_R_S, TGH_R_E, 1, 16, ActiveCell.Cells.Column)
　　　　　　　　
　　　　　　　　'行範囲指定で、表の列範囲を設定
　　　　　　　　Select Case ActiveCell.Row
　　　　　　　　　　Case 13 To 23　 '表1
　　　　　　　　　　　　bk_c = 34
　　　　　　　　　　　　Call Me.MTRX_add_color(TGH_R_S, TGH_R_E, 1, 16, ActiveCell.Cells.Column)
　　　　　　　　　　Case 24 To 28　 '表2
　　　　　　　　　　　　bk_c = 43
　　　　　　　　　　　　Call Me.MTRX_add_color(TGH_R_S, TGH_R_E, 1, 16, ActiveCell.Cells.Column)
　　　　　　　　　　Case 29 To 32　 '表3
　　　　　　　　　　　　bk_c = 43
　　　　　　　　　　　　Call Me.MTRX_add_color(TGH_R_S, TGH_R_E, 1, 16, ActiveCell.Cells.Column)
　　　　　　　　　　Case 37 To 42　 '表4
　　　　　　　　　　　　bk_c = 34
　　　　　　　　　　　　Call Me.MTRX_add_color(TGH_R_S, TGH_R_E, 1, 11, ActiveCell.Cells.Column)
　　　　　　　　　　Case 47 To 53　 '表5
　　　　　　　　　　　　bk_c = 43
　　　　　　　　　　　　Call Me.MTRX_add_color(TGH_R_S, TGH_R_E, 1, 16, ActiveCell.Cells.Column)
　　　　　　　　　　Case Else
　　　　　　　　　　　　MsgBox "指定外"
　　　　　　　　End Select　　　　　　
　　　　　　Else
　　　　　　　　MsgBox "左項目が見選択です"
　　　　　　　　Cancel = True
　　　　　　　　Exit Sub
　　　　　　End If
　　　　End If
　　　　
　　　　Cancel = True　　　　
　　End If　　　　　
End Sub

Sub MTRX_clear_color(mrs, mre, mcs, mce, tg_col)
　　　　'表範囲指定　mrs 表開始行、 mre 表最終行、 mcs 表開始列、 mce 表最終列、tg指定行　　　　
　　ActiveSheet.Range(Cells(mrs, tg_col), Cells(mre, mce)).Interior.ColorIndex = xlNone
End Sub

Function ck_Before_color()
　　
　　ck_Before_color = 0　　
　　'選択セルが2列目以降で、
　　If ActiveCell.Column > 1 Then
　　　　'If ActiveCell.Offset(0, -1).Interior.ColorIndex = xlNone Then
　　　　'If ActiveCell.Offset(0, -1).Interior.ColorIndex <> -4142 Then
　　　　'If ActiveCell.Offset(0, -1).MergeArea.Interior.ColorIndex <> -4142 Then　　　　
　　　　'左セルが色つきのとき
　　　　If Cells(ActiveCell.Row, ActiveCell.Offset(0, -1).MergeArea.Column).Interior.ColorIndex <> -4142 Then
　　　　　　ck_Before_color = 1
　　　　End If
　　ElseIf ActiveCell.Column = 1 Then
　　　　　　ck_Before_color = 1
　　End If
End Function


	【61932】Re:新しいウインドを開くのウインドウを...

ON - 09/6/12(金) 16:39 -


	引用なし

	パスワード

'Sheet2

Sub MTRX_add_color(mrs, mre, mcs, mce, tg_col)

　　Dim col_end

　　'選択セルに色付け######
　　'選択セルの最後が表最後の時
　　If ActiveCell.Column + ActiveCell.MergeArea.Columns.Count >= mce Then
　　　　'ActiveSheet.Range(Cells(mrs, tg_col), Cells(mre, tg_col)).Interior.ColorIndex = 40　　　　
　　　　If bk_c = 34 Then　'複数選択拒否
　　　　　　If Cells(Cells(ActiveCell.Row, 1).MergeArea.Row, 19) <> "" Then
　　　　　　　　MsgBox "同一項目で複数選択は出来ません。　変更する場合は選択しなおしてください"
　　　　　　　　Exit Sub
　　　　　　Else
　　　　　　　　ActiveSheet.Range(Cells(mrs, tg_col), Cells(mre, tg_col)).Interior.ColorIndex = 40
　　　　　　End If
　　　　　　
　　　　ElseIf bk_c = 43 Then　'複数選択ＯＫ
　　　　　　'ActiveSheet.Range(Cells(mrs, tg_col), Cells(mre, tg_col - 1)).Select
　　　　　　ActiveSheet.Range(Cells(ActiveCell.Row, ActiveCell.Column), Cells(ActiveCell.Row, ActiveCell.Column)).Select
　　　　　　'ActiveSheet.Range(Cells(mrs, tg_col), Cells(mre, tg_col)).Interior.ColorIndex = 40
　　　　　　'ActiveSheet.Range(Cells(mrs, tg_col), Cells(mre, tg_col - 1)).Interior.ColorIndex = 40
　　　　　　ActiveSheet.Range(Cells(ActiveCell.Row, ActiveCell.Column), Cells(ActiveCell.Row, ActiveCell.Column)).Interior.ColorIndex = 40　　　　
　　　　End If
　　　　
　　　　
　　　　'MsgBox "重複処理1"　　　　
　　　　'Range(Cells(ActiveCell.Row, ActiveCell.Column + 2), Cells(ActiveCell.Row + Cells(ActiveCell.Row, 1).MergeArea.Rows.Count - 1, ActiveCell.Column + 2)).Select
　　　　'Range(Cells(Cells(ActiveCell.Row, 1).MergeArea.Row, 19), Cells(Cells(ActiveCell.Row, 1).MergeArea.Row + Cells(ActiveCell.Row, 1).MergeArea.Rows.Count - 1, 19)).Select
　　　　'Range(Cells(Cells(ActiveCell.Row, 1).MergeArea.Row, 19), Cells(Cells(ActiveCell.Row, 1).MergeArea.Row + Cells(ActiveCell.Row, 1).MergeArea.Rows.Count - 1, 19)).FormulaR1C1 = Cells(ActiveCell.Row, 1).MergeArea.Row
　　　　
　　　　'複数選択制御
　　　　'19列書込み
　　　　'Range(Cells(Cells(ActiveCell.Row, 1).MergeArea.Row, 19), Cells(Cells(ActiveCell.Row, 1).MergeArea.Row + Cells(ActiveCell.Row, 1).MergeArea.Rows.Count - 1, 19)).FormulaR1C1 = Cells(ActiveCell.Row, 1).MergeArea.Row
　　　　'20列書込み
　　　　'Range(Cells(ActiveCell.Row, 20), Cells(ActiveCell.Row, 20)).FormulaR1C1 = ActiveCell.Row　　　　
　　　　'MsgBox Cells(Cells(ActiveCell.Row, 1).MergeArea.Row, 19)
　　　　If bk_c = 34 Then　　　　
　　　　　　If Cells(Cells(ActiveCell.Row, 1).MergeArea.Row, 19) <> "" Then
　　　　　　　　MsgBox "同一項目で複数選択は出来ません。　変更する場合は選択しなおしてください"
　　　　　　　　Exit Sub
　　　　　　Else
　　　　　　　　'19列書込み
　　　　　　　　Range(Cells(Cells(ActiveCell.Row, 1).MergeArea.Row, 19), Cells(Cells(ActiveCell.Row, 1).MergeArea.Row + Cells(ActiveCell.Row, 1).MergeArea.Rows.Count - 1, 19)).FormulaR1C1 = Cells(ActiveCell.Row, 1).MergeArea.Row
　　　　　　　　'20列書込み
　　　　　　　　Range(Cells(ActiveCell.Row, 20), Cells(ActiveCell.Row, 20)).FormulaR1C1 = ActiveCell.Row
　　　　　　End If
　　　　　　Exit Sub　　　　
　　　　ElseIf bk_c = 43 Then　　　　
　　　　　　　　'19列書込み
　　　　　　　　Range(Cells(Cells(ActiveCell.Row, 1).MergeArea.Row, 19), Cells(Cells(ActiveCell.Row, 1).MergeArea.Row + Cells(ActiveCell.Row, 1).MergeArea.Rows.Count - 1, 19)).FormulaR1C1 = Cells(ActiveCell.Row, 1).MergeArea.Row
　　　　　　　　'20列書込み
　　　　　　　　Range(Cells(ActiveCell.Row, 20), Cells(ActiveCell.Row, 20)).FormulaR1C1 = ActiveCell.Row
　　　　　　　　Exit Sub　　　'＄＄＄＄＄＄＄＄＄＄＄＄＄20090611
　　　　End If
　　Else　　
　　　　'MsgBox "重複処理11"
　　　　'ActiveSheet.Range(Cells(mrs, tg_col), Cells(mre, tg_col)).Interior.ColorIndex = 34
　　　　If bk_c = 34 Then
　　　　　　If Cells(Cells(ActiveCell.Row, 1).MergeArea.Row, 19) <> "" Then
　　　　　　　　MsgBox "同一項目で複数選択は出来ません。　変更する場合は選択しなおしてください"
　　　　　　　　Exit Sub
　　　　　　Else
　　　　　　　　'ActiveSheet.Range(Cells(mrs, tg_col), Cells(mre, tg_col)).Interior.ColorIndex = 34
　　　　　　　　ActiveSheet.Range(Cells(mrs, tg_col), Cells(mre, tg_col)).Interior.ColorIndex = bk_c
　　　　　　End If
　　　　
　　　　ElseIf bk_c = 43 Then
　　　　　　　　ActiveSheet.Range(Cells(mrs, tg_col), Cells(mre, tg_col)).Interior.ColorIndex = bk_c
　　　　End If
　　End If
　　
　　'Debug.Print ActiveCell.MergeArea.Column　　　　 '選択セルの列番
　　'Debug.Print ActiveCell.MergeArea.Columns.Count　'選択セルの結合セル状態　列数　1は結合セルでない
　　'Debug.Print ActiveCell.Offset(0, 1).MergeArea.Columns.Count　 '選択セルおよび結合セル時、次列の結合状態の列数
　　
　　'Debug.Print ActiveCell.MergeArea.Column + ActiveCell.MergeArea.Columns.Count + ActiveCell.Offset(0, 1).MergeArea.Columns.Count
　　'MsgBox ActiveCell.MergeArea.Column + ActiveCell.MergeArea.Columns.Count + ActiveCell.Offset(0, 1).MergeArea.Columns.Count
　　
　　'選択セルの次列の最後の列番取得
　　'MsgBox ActiveCell.MergeArea.Column + _
　　　　IIf(ActiveCell.MergeArea.Columns.Count <> 1, ActiveCell.MergeArea.Columns.Count, 0) + _
　　　　　　　　　　　　ActiveCell.Offset(0, 1).MergeArea.Columns.Count
　　　　　　　　　　　　
　　col_end = ActiveCell.MergeArea.Column + _
　　　　IIf(ActiveCell.MergeArea.Columns.Count <> 1, _
　　　　　　ActiveCell.MergeArea.Columns.Count, 0) + ActiveCell.Offset(0, 1).MergeArea.Columns.Count
　　　　　　
　　
　　'選択セルの次列の色付け処理#####
　　'選択セルと選択セルの次列が同行数のとき
　　If ActiveCell.Offset(0, 1).MergeArea.Rows.Count = ActiveCell.MergeArea.Rows.Count Then　　　　
　　　　If col_end >= mce Then
　　　　　　'MsgBox "最後"
　　　　　　'ActiveSheet.Range(Cells(mrs, tg_col + ActiveCell.MergeArea.Columns.Count), Cells(mre, tg_col + ActiveCell.MergeArea.Columns.Count)).Select
　　　　　　ActiveSheet.Range(Cells(mrs, tg_col + ActiveCell.MergeArea.Columns.Count), Cells(mre, tg_col + ActiveCell.MergeArea.Columns.Count)).Interior.ColorIndex = 40
　　　　　　
　　　　　　'MsgBox "重複処理2"
　　　　　　'Range(Cells(ActiveCell.Row, ActiveCell.Column + 2), Cells(ActiveCell.Row + Cells(ActiveCell.Row, 1).MergeArea.Rows.Count - 1, ActiveCell.Column + 2)).Select
　　　　　　'Range(Cells(Cells(ActiveCell.Row, 1).MergeArea.Row, 19), Cells(Cells(ActiveCell.Row, 1).MergeArea.Row + Cells(ActiveCell.Row, 1).MergeArea.Rows.Count - 1, 19)).Select
　　　　　　'Range(Cells(Cells(ActiveCell.Row, 1).MergeArea.Row, 19), Cells(Cells(ActiveCell.Row, 1).MergeArea.Row + Cells(ActiveCell.Row, 1).MergeArea.Rows.Count - 1, 19)).FormulaR1C1 = Cells(ActiveCell.Row, 1).MergeArea.Row
　　　　　　
　　　　　　
　　　　　　'複数選択制御
　　　　　　If bk_c = 34 Then　　　　　　
　　　　　　　　'MsgBox Cells(Cells(ActiveCell.Row, 1).MergeArea.Row, 19)
　　　　　　　　If Cells(Cells(ActiveCell.Row, 1).MergeArea.Row, 19) <> "" Then
　　　　　　　　　　MsgBox "同一項目で複数選択は出来ません。　変更する場合は選択しなおしてください"
　　　　　　　　　　Exit Sub
　　　　　　　　Else
　　　　　　　　　　'19列書込み
　　　　　　　　　　Range(Cells(Cells(ActiveCell.Row, 1).MergeArea.Row, 19), Cells(Cells(ActiveCell.Row, 1).MergeArea.Row + Cells(ActiveCell.Row, 1).MergeArea.Rows.Count - 1, 19)).FormulaR1C1 = Cells(ActiveCell.Row, 1).MergeArea.Row
　　　　　　　　　　'20列書込み
　　　　　　　　　　Range(Cells(ActiveCell.Row, 20), Cells(ActiveCell.Row, 20)).FormulaR1C1 = ActiveCell.Row
　　　　　　　　End If
　　　　　　
　　　　　　ElseIf bk_c = 43 Then
　　　　　　
　　　　　　　　'19列書込み
　　　　　　　　Range(Cells(Cells(ActiveCell.Row, 1).MergeArea.Row, 19), Cells(Cells(ActiveCell.Row, 1).MergeArea.Row + Cells(ActiveCell.Row, 1).MergeArea.Rows.Count - 1, 19)).FormulaR1C1 = Cells(ActiveCell.Row, 1).MergeArea.Row
　　　　　　　　'20列書込み
　　　　　　　　Range(Cells(ActiveCell.Row, 20), Cells(ActiveCell.Row, 20)).FormulaR1C1 = ActiveCell.Row
　　　　　　
　　　　　　End If
　　　　Else
　　　　
　　　　　　'MsgBox "手前"
　　　　　　'ActiveSheet.Range(Cells(mrs, tg_col + ActiveCell.MergeArea.Columns.Count), Cells(mre, tg_col + ActiveCell.MergeArea.Columns.Count)).Select
　　　　　　'ActiveSheet.Range(Cells(mrs, tg_col + ActiveCell.MergeArea.Columns.Count), Cells(mre, tg_col + ActiveCell.MergeArea.Columns.Count)).Interior.ColorIndex = 34
　　　　　　ActiveSheet.Range(Cells(mrs, tg_col + ActiveCell.MergeArea.Columns.Count), Cells(mre, tg_col + ActiveCell.MergeArea.Columns.Count)).Interior.ColorIndex = bk_c

　　　　
　　　　End If
　　　　
　　'選択セルと選択セルの次列の行数が異なるとき　何もしない
　　Else
　　
　　End If

　　ActiveCell.Select

End Sub


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

3484 / 13645 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free