Excel VBA質問箱 IV

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

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


20223 / 76732 ←次へ | 前へ→

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

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