[[20211122065807]] 『マクロで「飛び飛びセル選択に対応する指定行範囲』(マイン) >>BOT

[ 初めての方へ | 一覧(最新更新順) |

| 全文検索 | 過去ログ ]

 

『マクロで「飛び飛びセル選択に対応する指定行範囲クリア」』(マイン)

お世話になっております。

質問は

マウスでセル連続選択・飛び飛びセル選択に対する値のクリアについてです。

※クリアの条件:選択セルの位置する指定行範囲に対し値をクリア

シート構成:帳票

・個人のデータ入力範囲は8行あり表内に複数の個人が8行毎に登録

現在のコード

マウスで任意のセルを「連続選択」すると個人の行範囲をクリアする
ところまで作成できました。

このコードに
Ctl+クリックで「飛び飛びセル選択」に対しても同様にクリア
できるよう機能追加したいと考えております。

皆様何卒アドバイスのほどよろしくお願いいたします。

Sub 選択エリアで個人範囲クリア()

    '▼選択セルの行列番号取得
    Dim SelectArea As Range: Set SelectArea = Selection '1選択セル範囲取得
    Dim SelTopCol As Long: SelTopCol = SelectArea.Cells(1).Column '2先頭列
    Dim SelMaxCol As Long: SelMaxCol = SelectArea.Cells(SelectArea.Count).Column '3最終列

    Dim r As Long, c As Long, IDrow As Long

        With ActiveSheet
            '▼選択禁止
            If SelTopCol <= 29 Then MsgBox "項目は選択できません", vbOKOnly, "中止": Exit Sub
            '▼ID行の特定
            r = Cells(Rows.Count, 6).End(xlUp).row - 7'最終行
            c = 62'最終列
            For IDrow = 4 To r Step 8'セル位置からID行=クリアする先頭行を特定
                If Not Application.Intersect(ActiveCell, Range(Cells(IDrow, 30), Cells(IDrow + 7, c))) Is Nothing Then Exit For
            Next IDrow
            '▼個人エリア消去
            Application.ScreenUpdating = False
            .Range(.Cells(IDrow, SelTopCol), .Cells(IDrow + 7, SelMaxCol)).Value = ""
            Application.ScreenUpdating = True
        End With

End Sub

< 使用 Excel:Excel2019、使用 OS:Windows10 >


補足しました。

    Dim SelectArea As Range: Set SelectArea = Selection '1選択セル範囲取得
    Dim SelTopCol As Long: SelTopCol = SelectArea.Cells(1).Column '2選択セルの先頭列
    Dim SelMaxCol As Long: SelMaxCol = SelectArea.Cells(SelectArea.Count).Column '3選択セルの最終列
(マイン) 2021/11/22(月) 07:14

 Sub test()
    Dim rng As Range
    For Each rng In Selection
        Debug.Print rng.Row
 '        .Range(.Cells(rng.row, SelTopCol), .Cells(rng.row, SelMaxCol)).Value = ""
    Next
 End Sub

 これで選択範囲の全ての行番号が分かります。
(ponpon) 2021/11/22(月) 08:10

書いてしまったので、そのまま。

 以下のサンプルを実行してみてください。
 それぞれ、For Each NextでのRangeオブジェクトのアドレスを
 イミディエイトウィンドウに出力します。
 その内容でロジックを組み直してみては。

 Sub sample()
     Debug.Print Selection.Address(0, 0)
     Dim r As Range
     For Each r In Selection
         Debug.Print r.Address(0, 0)
     Next

     For Each r In Selection.Areas
         Debug.Print r.Address(0, 0)
     Next
 End Sub

(tkit) 2021/11/22(月) 08:15


ponpon さん ありがとうございます。

tkit さんの方法で

それぞれの選択範囲の先頭列・最終列を取得してみました。

Sub sample()

     Dim r As Range
     Dim c1 As Long, c2 As Long
     For Each r In Selection.Areas
         c1 = r.Column
         c2 = c1 + Range(r.Address(0, 0)).Columns.Count - 1
         Debug.Print c1 & "〜" & c2
     Next
 End Sub

あとは、選択範囲をクリアできるか試し
UNIONで一括で消去できるかもためしてみたいと思います。

またご報告いたします。
(マイン) 2021/11/22(月) 09:20


 こういうのが知りたい?

 MsgBox SelectArea.Areas(1).Cells(1).Column

 With SelectArea.Areas(SelectArea.Areas.Count)
     MsgBox .Cells(.Cells.Count).Column
 End With
(にくちゃんねる) 2021/11/22(月) 09:28

 ★混乱するとよくないので一段落してからお読みください★

■1
「Intersectメソッド」が理解できているのであれば、↓のような判定は避けたほうがよいと思います。

 SelTopCol = SelectArea.Cells(1).Column
 If SelTopCol <= 29 Then

■2
解ってやっているなら別によいですが、基本的にマルチステートメントは避けた方がよいとおもいます。
(特に質問サイトで質問しているような段階なら基本形で書いた方が後々混乱しなくてよいと思います)

■3
>UNIONで一括で消去できるかもためしてみたいと思います。

↑のようにコメントされているので、半ば気づいていらっしゃるようですが、こういうアプローチもあったとおもいます。

    Sub 別案()
        Dim i As Long
        Dim MyRNG As Range

        If TypeName(Selection) <> "Range" Then
            MsgBox "セル以外が選択されているので処理を中止します"
        Else
            With Selection
                For i = 0 To (.Areas(.Areas.Count).Cells(.Areas(.Areas.Count).Cells.Count).Row - 4) \ 8 Step 1
                    If Not Intersect(.EntireRow, .Parent.Range("AD4:BJ11").Offset(i * 8)) Is Nothing Then
                        If MyRNG Is Nothing Then
                            Set MyRNG = .Parent.Range("AD4:BJ11").Offset(i * 8)
                        Else
                            Set MyRNG = Union(MyRNG, .Parent.Range("AD4:BJ11").Offset(i * 8))
                        End If
                    End If
                Next i
            End With
        End If

        If Not MyRNG Is Nothing Then
            MyRNG.Select 'これがClearContentsされればよい
        End If
    End Sub

(もこな2) 2021/11/22(月) 19:35


もこな2 さんありがとうございます。

アドバイスを参考に下記で希望通りの処理ができるようになりました。

Sub テスト3()

    Dim r As Long, IDrow As Long
    With ActiveSheet
        '▼選択禁止
        If Selection.Column <= 29 Then MsgBox "項目列は選択できません", vbOKOnly, "中止": Exit Sub
        '▼ID行の特定
        r = Cells(Rows.Count, 6).End(xlUp).Row - 7
        For IDrow = 4 To r Step 8
            If Not Application.Intersect(ActiveCell, Range(Cells(IDrow, 30), Cells(IDrow + 7, 62))) Is Nothing Then Exit For
        Next IDrow
        '▼選択列の特定
        Dim rng As Range, c1 As Long, c2 As Long, MyRNG As Range
        For Each rng In Selection.Areas
            'c1=選択先頭列 c2=選択最終列
            c1 = rng.Column
            c2 = c1 + Range(rng.Address(0, 0)).Columns.Count - 1 '差分-1
            '選択範囲ごとにUnionに格納
            If MyRNG Is Nothing Then
                Set MyRNG = .Range(.Cells(IDrow, c1), .Cells(IDrow + 7, c2))
            Else
                Set MyRNG = Union(MyRNG, .Range(.Cells(IDrow, c1), .Cells(IDrow + 7, c2)))
            End If
        Next
        '▼個人エリア消去
        Application.ScreenUpdating = False
        If Not MyRNG Is Nothing Then
            MyRNG.Select '.ClearContents
        End If
        Application.ScreenUpdating = True
    End With
End Sub
(マイン) 2021/11/22(月) 20:06

追伸

UNIONは遅いと聞きますので実際どうなのか
実際のデータを使用してUNION「使用」「未使用」とで比較してみました。

(UNION未使用)※ループ内で都度クリアする方法

 For Each rng In Selection.Areas
     c1 = rng.Column
     c2 = c1 + Range(rng.Address(0, 0)).Columns.Count - 1 '差分-1
     .Range(.Cells(IDrow, c1), .Cells(IDrow + 7, c2)).Value = "" '選択範囲ごとにクリア
 Next

UNION

 0.015625 
 0.0234375 
 0.015625 
 0.015625 
 0.0078125 
 0.015625 

都度クリア

 0.0390625 
 0.046875 
 0.046875 
 0.0390625 
 0.0390625 
 0.046875 

(マイン) 2021/11/22(月) 20:39


数が多くないと、遅いとは思わない。
エリアで無く、セルの数が4000個とかでやってみては?
実際、PCも向上しているし、VBAの処理速度も向上しているし…、試してみないとよく解らない。
(にくちゃんねる) 2021/11/22(月) 21:19

■4
同時進行されると、混乱すると思ったので、最初に「一段落してからお読みください」と書いたつもりですが大丈夫ですか?

■5
もしも、比較するなら極力条件は合わせないと正しくないと思いますよ。

    Sub 別案_別々版()
        Dim i As Long

        If TypeName(Selection) <> "Range" Then
            MsgBox "セル以外が選択されているので処理を中止します"
        Else
            With Selection
                For i = 0 To (.Areas(.Areas.Count).Cells(.Areas(.Areas.Count).Cells.Count).Row - 4) \ 8 Step 1
                    If Not Intersect(.EntireRow, .Parent.Range("AD4:BJ11").Offset(i * 8)) Is Nothing Then
                            Parent.Range("AD4:BJ11").Offset(i * 8).ClearContents
                    End If
                Next i
            End With
        End If
    End Sub

(もこな2) 2021/11/22(月) 21:22


もこな2 さん

行範囲を求める方法について、アドバイスいただいた別案でやってみました。

Sub テスト5()

    '入力エリアか判定
    If Intersect(ActiveCell, Range(Cells(4, 30), Cells(Cells(Rows.Count, 6).End(xlUp).Row, 62))) Is Nothing Then
        MsgBox "入力エリア外です", vbCritical + vbOKOnly, "範囲外"
        Exit Sub
    End If

    Dim r As Range, c1 As Long, c2 As Long
    Dim i As Long, MyRNG As Range
    'セルを選択しているか判定
    If TypeName(Selection) <> "Range" Then
        MsgBox "セル以外が選択されているので処理を中止します"
    Else
        With Selection
            For i = 0 To (.Areas(.Areas.Count).Cells(.Areas(.Areas.Count).Cells.Count).Row - 4) \ 8 Step 1 'どの行範囲か特定
                If Not Intersect(.EntireRow, .Parent.Range("AD4:BJ11").Offset(i * 8)) Is Nothing Then
                    For Each r In .Areas
                        'c1=選択先頭列 c2=選択最終列
                        c1 = r.Column
                        c2 = c1 + Range(r.Address(0, 0)).Columns.Count - 1 '差分-1
                        '選択範囲ごとにUnionに格納
                        If MyRNG Is Nothing Then
                            Set MyRNG = .Parent.Range(Cells(4, c1), Cells(11, c2)).Offset(i * 8)
                        Else
                            Set MyRNG = Union(MyRNG, .Parent.Range(Cells(4, c1), Cells(11, c2)).Offset(i * 8))
                        End If
                    Next r
                End If
            Next i
        End With
    End If
    If Not MyRNG Is Nothing Then
        Application.ScreenUpdating = False
        MyRNG.ClearContents                      'これがClearContentsされればよい
        Application.ScreenUpdating = True
    End If

End Sub
(マイン) 2021/11/23(火) 08:21


■6
再三になりますが、同時進行されると混乱しませんか?本当に大丈夫ですか?

■7
>入力エリアか判定
そもそもの目的(必要性)がわかりませんが、【選択しているセル】に30行目未満が含まれているか判定したいのであれば「ActiveCell」を基準にするのは不適当でしょう。

■8

 c1 = r.Column
 c2 = c1 + Range(r.Address(0, 0)).Columns.Count - 1 '差分-1

↑は↓でよくありませんか?

 c2 = c1 + r.Columns.Count - 1 '差分-1

■9

 c1 = r.Column
 c2 = c1 + Range(r.Address(0, 0)).Columns.Count - 1 '差分-1
 Set MyRNG = .Parent.Range(Cells(4, c1), Cells(11, c2)).Offset(0 * 8)

↑も↓でよくありませんか?
 Set MyRNG = Intersect(r.Parent.Rows("4:11"), r.EntireColumn)

■10
↓のループにはどのような狙いがあるのですか?

 For Each r In .Areas
     省略
 Next r

強いて言えば、セル範囲ごとに、クリアしたい【列範囲】が異なるのでしょうか?

(もこな2) 2021/11/23(火) 15:17


↑の訂正。

 誤 【選択しているセル】に30行目未満が含まれているか
 正 【選択しているセル】にAD列より前の列が含まれているか

(もこな2) 2021/11/23(火) 18:49


もこな2 さん

度重なるアドバイス感謝いたします。
ご質問と当方が何をしているのか、下記のとおりまとめてみました。

■6
再三になりますが、同時進行されると混乱しませんか?本当に大丈夫ですか?

→はい、Intesectについて学びを深めたいと考えておりますので感謝しております。

■7
>入力エリアか判定

→確認したところご指摘の通り複数選択した場合に、ActiveCell以外の部分を考慮していませんでした。

  下記のように修正しました。

    '入力エリアか判定
    Dim rSel As Range, rChk As Range
    Set rSel = Selection
    Set rChk = Intersect(rSel, Range(Cells(4, 30), Cells(Cells(Rows.Count, 6).End(xlUp).Row, 62)))
    If rChk Is Nothing Then '単一セルはみ出し
        MsgBox "入力エリア外です", vbOKOnly, "範囲外"
        Exit Sub
    Else
        If rChk.Count <> rSel.Count Then '複数セルの一部はみ出し
            MsgBox "入力エリア外です", vbOKOnly, "一部が範囲外"
            Exit Sub
        End If
    End If
    Set rSel = Nothing
    Set rChk = Nothing

■8
c2 = c1 + Range(r.Address(0, 0)).Columns.Count - 1 '差分-1

→ご指摘のとおり、Range(r.Address(0, 0))は無駄で

  c2 = c1 + r.Columns.Count - 1 '差分-1 
  で連続選択したセルの最終列が取得できました。

■9 ■10

→説明不足で申し訳ございません。

  処理は「セル範囲ごとにクリアする」ものを作成しております。

  処理については
  ・個人単位…複数個人にまたがってセル選択した場合は、ActiveCellがある個人のみ処理する
  ・セル選択方法…「単一セル・連続選択セル・飛び飛び(Ctl+選択)」でも対応できる
  といったことを想定しております。

→アドバイスを頂いたコードを元にデバッグしながら下記のようにいたしました。

・個人単位…

  個人エリアが特定したら「flg = True、Exit For」で抜けて

	For i = 0 To (.Areas(.Areas.Count).Cells(.Areas(.Areas.Count).Cells.Count).Row - 4) \ 8 Step 1 'どの行範囲か特定
		If Not Intersect(.EntireRow, .Parent.Range(Cells(4, 30), Cells(11, 62)).Offset(i * 8)) Is Nothing Then
			flg = True 
			Exit For
		End If
	Next i

・セル選択方法…

  選択セル範囲毎にUNIONに格納していく

	If flg = True Then
	   For Each r In .Areas
		 省略(セル範囲毎に選択セルを取得)
	   Next r
	End If  

 ・動作確認ができたコードは下記になります。

 Sub 選択エリア範囲クリア()
    'セルを選択しているか判定
    If TypeName(Selection) <> "Range" Then
        MsgBox "セル以外が選択されているので処理を中止します"
        Exit Sub
    End If
    '入力エリアか判定
    Dim rSel As Range, rChk As Range
    Set rSel = Selection
    Set rChk = Intersect(rSel, Range(Cells(4, 30), Cells(Cells(Rows.Count, 6).End(xlUp).Row, 62)))
    If rChk Is Nothing Then '単一セルはみ出し
        MsgBox "入力エリア外です", vbOKOnly, "範囲外"
        Exit Sub
    Else
        If rChk.Count <> rSel.Count Then '複数セルの一部はみ出し
            MsgBox "入力エリア外です", vbOKOnly, "一部が範囲外"
            Exit Sub
        End If
    End If
    Set rSel = Nothing
    Set rChk = Nothing

    '個人エリア特定
    Dim r As Range, MyID As Variant
    Dim i As Long, MyRNG As Range, flg As Boolean
    With Selection
        For i = 0 To (.Areas(.Areas.Count).Cells(.Areas(.Areas.Count).Cells.Count).Row - 4) \ 8 Step 1 'どの行範囲か特定
            If Not Intersect(.EntireRow, .Parent.Range(Cells(4, 30), Cells(11, 62)).Offset(i * 8)) Is Nothing Then
                flg = True                       'アクティブセルがある8行おきにある個人領域のみを対象とする
                Exit For
            End If
        Next i
        If flg = True Then
            For Each r In .Areas
                If MyRNG Is Nothing Then         'Unionに選択範囲単位で格納
                    Set MyRNG = Intersect(r.Parent.Rows("4:11"), r.EntireColumn).Offset(i * 8)
                Else
                    Set MyRNG = Union(MyRNG, Intersect(r.Parent.Rows("4:11"), r.EntireColumn).Offset(i * 8))
                End If
            Next r
        End If
    End With
    'クリア
    If Not MyRNG Is Nothing Then
        Application.ScreenUpdating = False
        MyRNG.Select                             'ClearContents
        Application.ScreenUpdating = True
    End If
End Sub

(マイン) 2021/11/23(火) 19:49


■11
>Intesectについて学びを深めたい
では↓を読まれるとよいと思います。
http://officetanaka.net/excel/vba/tips/tips118.htm
https://excel-ubara.com/excelvba1/EXCELVBA402.html
https://www.moug.net/tech/exvba/0050074.html

■12
>下記のように修正しました。
本人が納得できる方法が一番だと思いますが、私ならこうします。

    Sub 実験01()
        Dim bufRNG As Range

        'セルを選択しているか判定
        If TypeName(Selection) <> "Range" Then
            MsgBox "セル以外が選択されているので処理を中止します"
            Exit Sub
        End If

        Set bufRNG = Intersect(Selection, Range("A:AC"))
        If bufRNG Is Nothing Then
            MsgBox "AD列より前は選択されていません"
        Else
            If Selection.Address = bufRNG.Address Then
                MsgBox "AD列より前しか選択されていません"
            Else
                MsgBox "選択されているセル範囲にAD列より前のセルが含まれています"
            End If
        End If
    End Sub

要は、判定するにしても、SelectionがA〜AC列に入ってるかどうかを判定すれば十分じゃないかと。

■13
> ・個人単位…複数個人にまたがってセル選択した場合は、ActiveCellがある個人のみ処理する
なるほど。個人的には違和感がでる処理ですが、まぁそういうことが前提なら複雑化しますねぇ。
ただ、それならUnionした範囲を処理しちゃだめですよね。(複数人分を処理することになってしまうので)

(もこな2) 2021/11/23(火) 21:59


■14
>・個人単位…複数個人にまたがってセル選択した場合は、ActiveCellがある個人のみ処理する
↑の仕様で考えてみました。

    Sub 実験02()
        Dim MyRNG As Range
        Dim i As Long

        'セルを選択しているか判定
        If TypeName(Selection) <> "Range" Then
            MsgBox "セル以外が選択されているので処理を中止します"
            Exit Sub
        End If

        For i = 4 To ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row Step 8
            If Not Intersect(Selection, ActiveSheet.Cells(i, "AD").Resize(8, 33)) Is Nothing Then
                If MyRNG Is Nothing Then
                    Set MyRNG = ActiveSheet.Cells(i, "AD").Resize(8, 33)
                Else
                    MsgBox "複数人が選択されています" & vbLf & "アクティブセル依存モードに移行します"
                    If ActiveCell.Row < 4 Then
                        MsgBox "アクティブセルが4行目未満のため処理を中止します"
                        Exit Sub
                    Else
                        Set MyRNG = ActiveSheet.Cells(ActiveCell.Row - ((ActiveCell.Row - 4) Mod 8), "AD").Resize(8, 33)
                        Exit For
                    End If
                End If
            End If
        Next i

        MsgBox MyRNG.Address(False, False) & " をクリアしてください"
    End Sub

ちょっと悩みましたが、二人目が来ちゃったときだけ、アクティブセルに依存すると考えればよさそうですね。

(もこな2) 2021/11/23(火) 23:36


もこな2 さん

ありがとうございます。

"アクティブセル依存モードに移行します"

なんか、カッコよくかつ、相手にわかりやすく良いですね。

仕事の合間見ながら確認したいと思います。
(マイン) 2021/11/24(水) 09:31


 >このコードに
 >Ctl+クリックで「飛び飛びセル選択」に対しても同様にクリア
 >できるよう機能追加したいと考えております。

このコードが出来れば、あとはそれを繰り返すだけなので、
このコードをまずはブラッシュアップしていきましょう。

Sub test()

    Dim rngList As Range        'データセル範囲
    Dim rngOperation As Range   '操作対象セル範囲
    Dim rngTarget As Range      'クリア対象セル範囲
    Dim ix As Long

    If TypeName(Selection) <> "Range" Then Exit Sub

    With ActiveSheet
        Set rngList = .Range(.Range("A4"), .Cells(.UsedRange.Count))
        Set rngOperation = Intersect(rngList, .Range(.Columns("AC"), .Columns(.Columns.Count)))
    End With
    ix = (Selection.Row - rngList.Row + 1) \ 8 * 8
    Set rngTarget = Intersect(rngOperation, ActiveSheet.Cells(ix, "AC").Resize(8).EntireRow)

    rngTarget.Select
    If MsgBox("OK?", vbYesNo) = vbYes Then rngTarget.ClearContents
End Sub

こんなことをやりたいのかなぁと書いてみましたが、
セルの位置関係がよくわからないので、うまく動作しないかもです。
シート上のイメージややりたいことを伝えてもらえるといいかもです。

もしかしたら、複数セル選択より、特定のセルダブルクリックで、
都度都度クリアして行けた方が使いやすいかなぁと思ったり。

(まっつわん) 2021/11/24(水) 09:43


訂正>>

 > Set rngOperation = Intersect(rngList, .Range(.Columns("AC"), .Columns(.Columns.Count)))

Set rngOperation = application.Range(rnglist.Columns("AC"), rnglist.Columns(.Columns.Count)))
(まっつわん) 2021/11/24(水) 09:49


まっつわん さん いつもお世話になっております。

・特定のセルダブルクリック

  →入力エリア内は
    WorksheetChangeで「右クリックメニュー・ダブルクリック」のイベントを設定
    しております。ですので・・・
    セル選択・Ctrl+クリックで選択させて値をクリアするという方法をとっております。
(マイン) 2021/11/24(水) 10:04

補足:書き忘れていました。

特定のセルダブルクリックで、
都度都度クリアして行けた方が使いやすいかなぁと思ったり。

→現在作成しているコードはユーザーが

  ・入力データーのセル選択
  ・UserFormのコマンドボタン実行(本コード)
  にてデータがクリアされるようにしております。
(マイン) 2021/11/24(水) 12:25

とりあえずですが報告いたします。

実務ファイルで動作確認が取れましたので下記の通り作成しました。

・同じような処理をするシートが複数あるため

 「選択セルチェック」「クリア処理」を呼び出せるように作り直しました。

Sub 選択エリアで個人範囲クリア()

    'セルを選択しているか判定
    If TypeName(Selection) <> "Range" Then MsgBox "セル以外が選択されているので処理を中止します": Exit Sub

    Dim Top_Row As Long, End_Row As Long, Top_Col As Long, End_Col As Long, Cnt_Step As Long, Cnt_Area As String, Cnt_Row As Long
    Dim flg1 As Boolean, flg2 As Boolean
    If ActiveSheet.Cells(1, 18).Value = "シートA" Then
        'セル位置の設定
        Top_Row = 20
        End_Row = Cells(Rows.Count, 17).End(xlUp).Row
        Top_Col = Format(DateSerial(Year(Cells(1, 23)), Month(Cells(1, 23)) + 1, 0), "d") + 23
        End_Col = 180
        Cnt_Step = 6
        Cnt_Area = "20:25"
        Cnt_Row = 25
        '入力エリアを選択しているか判定(入力エリア外選択・一部はみ出し対応)
        Call 選択エリア範囲_エリアチェク(Top_Row, End_Row, Top_Col, End_Col, flg1, flg2)
        If flg1 = True Then MsgBox "入力エリア外です", vbOKOnly, "範囲外": Exit Sub 'セルはみ出し
        If flg2 = True Then MsgBox "入力エリア外です", vbOKOnly, "一部が範囲外": Exit Sub '複数セルの一部はみ出し
        '個人の選択(連続・飛び飛び選択対応)セルデータ入力範囲をクリア
        Call 選択エリア範囲_クリア(Top_Row, End_Row, Top_Col, End_Col, Cnt_Step, Cnt_Area, Cnt_Row)

    ElseIf ActiveSheet.name = "シートB" Then

        Top_Row = 4
        End_Row = Cells(Rows.Count, 6).End(xlUp).Row
        Top_Col = 30
        End_Col = 62
        Cnt_Step = 8
        Cnt_Area = "4:11"
        Cnt_Row = 11

        Call 選択エリア範囲_エリアチェク(Top_Row, End_Row, Top_Col, End_Col, flg1, flg2)
        If flg1 = True Then MsgBox "入力エリア外です", vbOKOnly, "範囲外": Exit Sub
        If flg2 = True Then MsgBox "入力エリア外です", vbOKOnly, "一部が範囲外": Exit Sub

        Call 選択エリア範囲_クリア(Top_Row, End_Row, Top_Col, End_Col, Cnt_Step, Cnt_Area, Cnt_Row)

    Else
        MsgBox "このシートは処理対象外", vbOKOnly, "中止": Exit Sub
    End If

End Sub

'入力エリアを選択しているか判定(入力エリア外選択・一部はみ出し対応)
Function 選択エリア範囲_エリアチェク(Top_Row As Long, End_Row As Long, Top_Col As Long, End_Col As Long, _

                        flg1 As Boolean, flg2 As Boolean)
    Dim rngCHK As Range
    Set rngCHK = Intersect(Selection, Range(Cells(Top_Row, Top_Col), Cells(End_Row, End_Col)))
    If rngCHK Is Nothing Then
        flg1 = True                              'セルはみ出し
    Else
        If Selection.Address <> rngCHK.Address Then
            flg2 = True                          '複数セルの一部はみ出し
        End If
    End If
    Set rngCHK = Nothing
End Function

'個人の選択(連続・飛び飛び選択対応)セルデータ入力範囲をクリア
Function 選択エリア範囲_クリア(Top_Row As Long, End_Row As Long, _

                     Top_Col As Long, End_Col As Long, Cnt_Step As Long, Cnt_Area As String, Cnt_Row As Long)
    '個人エリア特定
    Dim i As Long, flg As Boolean                ', MyID As Variant
    With Selection
        For i = 0 To (.Areas(.Areas.Count).Cells(.Areas(.Areas.Count).Cells.Count).Row - Top_Row) \ Cnt_Step Step 1 'どの行範囲か特定
            If Not Intersect(.EntireRow, .Parent.Range(Cells(Top_Row, Top_Col), Cells(Cnt_Row, End_Col)).Offset(i * Cnt_Step)) Is Nothing Then
                flg = True                       'アクティブセルがある領域のみを対象とする
                'MyID = .Parent.Cells(4, 9).Offset(i * 8) 'ID番号を取得
                Exit For
            End If
        Next i
        'Unionにそれぞれの選択範囲を格納
        Dim r As Range, MyRNG As Range
        If flg = True Then
            For Each r In .Areas
                If MyRNG Is Nothing Then
                    Set MyRNG = Intersect(r.Parent.Rows(Cnt_Area), r.EntireColumn).Offset(i * Cnt_Step)
                Else
                    Set MyRNG = Union(MyRNG, Intersect(r.Parent.Rows(Cnt_Area), r.EntireColumn).Offset(i * Cnt_Step))
                End If
            Next r
        End If
    End With
    'クリア
    If Not MyRNG Is Nothing Then
        Application.ScreenUpdating = False
        MyRNG.ClearContents                      'Select させてメッセージでクリアもあり
        Application.ScreenUpdating = True
    End If
End Function
(マイン) 2021/11/26(金) 09:02

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.