Excel VBA質問箱 IV

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

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


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

20222 / 76732

←次へ　｜　前へ→


	【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

376 hits

▼

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