| |
/////////////////////////////////////////////////////////////
'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
|
|
ON
- 09/6/12(金) 16:37 -
