Excel VBA質問箱 IV

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

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


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

【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:新しいウインドを開くのウインドウを閉... ON 09/6/5(金) 16:17 質問[未読]
【61808】Re:新しいウインドを開くのウインドウを閉... yoshi 09/6/5(金) 18:17 回答[未読]
【61809】Re:新しいウインドを開くのウインドウを閉... ON 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方を閉じるときです)
常に2つの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 さん:
こんにちは

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

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

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

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

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

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

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

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

引用なし
パスワード
   皆様 レス頂ながら大変遅くなりました m(_ _)m


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

>常に2つの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 の理解はまだ出来ていません


また
24.すべてのウインドウを列挙する
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 の b2あたりにトグルボタンを作成して
下記コード貼れば再現できると思います
よろしくお願いいたします

----------------------------------------------------------------------
'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 = "DTセット(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 = "DTセット(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 = "DTセット(2画面表示)"
  Parent.Unprotect
  Windows(Parent.Name & ":2").Close
  ActiveWindow.WindowState = xlMaximized
 End If
End Sub

【61804】Re:新しいウインドを開くのウインドウを...
質問  ON  - 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:新しいウインドを開くのウインドウを...
質問  ON  - 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 = "DTセット(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 -

引用なし
パスワード
   ▼ON さん:
>上記で
>マクロブック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 = "DTセット(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 = "戻る(1画面表示面)" '戻 る) → 戻る(1画面表示)
  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 = "DTセット(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 '複数選択OK   '24-28 不具合 !!!! 20090611 nnnnnnnnnnnnnnnnnnnnn
        
          '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 '複数選択OK
      '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

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