Excel VBA質問箱 IV

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

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


20224 / 76732 ←次へ | 前へ→

【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

298 hits

【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 発言

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