Excel VBA キーワードから列を取得して、さらに空欄行を非表示にする

はじめて質問させていただきます。よろしくお願いいたします。

【やりたいこと】
①C1セルで管轄を絞り、該当以外を非表示にする　←一応できていること
②E1のキーワードで列を取得し、該当の列から空欄行を非表示にする　←できていないこと
　例)「特別な周知」を選んだ場合、社長・専務・部長だけが表示されている状態にする
③抽出されたメールアドレスだけを、コピーした状態にする　←一応できていること

「特別な周知」「一般周知」「依頼」により、メールを送る相手が異なるので、その条件にあった方だけを表示し、アドレスをコピーしたいという内容になります。
リストが数百人に及ぶため、VBAで抽出できないかと考えております。

①については、以下のコードで一応ソートはかけられてます。
Sub ソート()
Rows.Hidden = False
　 Application.ScreenUpdating = False
Dim Ws As Worksheet
Set Ws = Worksheets("Sheet1")
Dim Cmax As Long
Cmax = Ws.Range("A65536").End(xlUp).Row
Dim keyWord As String
keyWord = Range("C1")
Dim i As Long
Dim Kankatsu As String
For i = 4 To Cmax
Kankatsu = Ws.Range("B" & i).Value
If InStr(Kankatsu, keyWord) > 0 Then
Else
Rows(i).Hidden = True
End If
Next
　 Application.ScreenUpdating = True
End Sub

②については、列の取得はできるもののそこから空欄を非表示にすることが出来ません。
Sub 指定した文字列の列を取得()
Dim key As Long
key = Rows(6).Find(Range("I2")).Column
End Sub

③については、表示されているアドレスだけをコピーできてます。
Sub アドレスコピー()
Dim endRow As Long
endRow = Cells(Rows.Count, 4).End(xlUp).Row
Range(Cells(4, 4), Cells(endRow, 4)).Copy
MsgBox "アドレスをコピーしました。"
End Sub

最終的に、①管轄でソート→②項目列を選択し空欄を非表示→③メールアドレスをコピーを[抽出]ボタン一つで出来るようにしたいと思っております。(画像3枚目)
何卒、よろしくお願いいたします。

No.3 ベストアンサー 回答者： Qchan1962 回答日時： 2022/10/22 00:54

やはり記録マクロを使いフィルタで処理するのが簡単かと

実際に記録して試してください
範囲を選択する時はショートカットキー　Ctrl+Shift+＊で

記録を少しまとめ②を追加するとこんな感じ・・
Sub Macro1test()
'
' Macro1 Macro
'
Dim objColm As Range
Dim colm2 As Long
Set objColm = Rows(3).Find(Range("E1").Text) '②の検索
'Findの使い方はもう少し丁寧にするべきですがとりあえず
If Not objColm Is Nothing Then　'Findのエラーを回避する為
colm2 = objColm.Column '②の列№
Else
MsgBox "列が見つかりません": Exit Sub
End If
With Range("A3").CurrentRegion 'データ範囲
.AutoFilter
.AutoFilter Field:=2, Criteria1:=Range("C1").Text '①
.AutoFilter Field:=colm2, Criteria1:="<>" '②
.Columns(4).Offset(1).Copy Sheets("Sheet2").Range("A1") '③
.AutoFilter
End With
End Sub

ｇボタン押されたようなのでつい書いてしまったけれど、記録と見比べて検証してみてください
Offset(1)だけなので少し問題が残るかも知れません・・

この回答へのお礼

Qchan1962様
二回もご回答ありがとうとございました。

＞Range(Cells(4, 4), Cells(endRow, 4)).Copy
D列のみコピーで先は？
　→アドレスをコピー後は、OutlookのToに張り付けるため、コピー状態で完了という流れを想定しておりました。

ご助言の通り、何度かマクロを記録してみましたが、一発で該当するものだけを表示するのは難しいということがわかりました。

大変勉強になりました。

二回のご回答をいただいた、Qchan1962様をベストアンサーに選ばせていただきます。

ありがとうございました。

お礼日時：2022/10/22 07:32

No.2 回答者： fujillin 回答日時： 2022/10/21 23:37

こんばんは

各行を判断して非表示にしているようですが、同じ非表示にすれば良いだけなら、エクセルのフィルター機能を利用したほうが簡単ではないでしょうか？
コピーはできるとのことですので、以下は、フィルターで抽出するだけのサンプルです。


＞例)「特別な周知」を選んだ場合、社長・専務・部長だけが表示～
とのことですが、東京の場合は「○」のある課長も抽出されてよいものと勝手に解釈しました。

＞以下のコードで一応ソートはかけられてます。
ご質問文には「ソート」と書いてありますが、ソートは行っていないようなので、抽出処理のみを行っています。

Sub Q_13197135()
Dim r As Range, c As Range, col As Long

With Worksheets("Sheet1")
.Cells(3, 1).AutoFilter
Set r = Range(.Cells(3, 1), .Cells(Rows.Count, 1).End(xlUp)).Resize(, 8)
If r(1).Row < 3 Then Exit Sub
For Each c In .Range("F3:H3")
If c.Value = .Cells(1, 4).Value Then col = c.Column
Next c
If col < 6 Then col = 2
r.AutoFilter col, "<>"
r.AutoFilter 2, .Cells(1, 2).Text
End With
End Sub

この回答へのお礼

fujillin様
ご回答ありがとうございました。

各行を判断して非表示にしているようですが、同じ非表示にすれば良いだけなら、エクセルのフィルター機能を利用したほうが簡単ではないでしょうか？
　→大変おっしゃる通りなのですが、実際のExcelは、A~M列に社名・担当者名・住所等の情報があり、項目(特別な周知・一般周知等)はN~X列に分類されております。そのため右へのスクロールが大変煩わしくなったためご質問するに至りました。
　ウィンドウ枠の固定も行ってはいるものの、情報量が多いのであまり効果的ではなく、では項目(特別な周知・一般周知等)をA列側に移動すればいいのではと修正したのですが、今度は項目のフラグが付けずらい等の意見が上がり断念した次第です。社名、担当者名、役職の列があって項目がある方が、フラグ付けがしやすいという意見です。

お二人からいただいた内容を、自分なりに理解し利用させていただきたいと思います。
この度は、大変ありがとうございました。

お礼日時：2022/10/22 07:37

No.1 回答者： Qchan1962 回答日時： 2022/10/21 23:12

こんばんは

多分・・記録マクロでフィルタ操作を記録して・・少し改修
SpecialCells(xlCellTypeVisible)などを使って③を実行するのが良いかな？
多分これが簡単です
Hiddenで非表示にするとSpecialCellsが使えなかった気がしますしね

＞Range(Cells(4, 4), Cells(endRow, 4)).Copy
D列のみコピーで先は？　

①②で非表示にすると言う事は2つの条件がTrueの場合に
Rows(i).Hidden = True　とするべきなのかな・・と言う事は分けて実行せずに2つの条件をAndにすれば良さそう・・・

フィルタでないやり方を試してみます（すみません元コードを見ていたら混乱してきたので書き替えて）

Functionで条件を投げて
非表示処理と非表示にならない範囲（この場合D列）を作成して戻します

Worksheets("Sheet2").Range("A1")にペースト

Sub test01()
Dim Ws As Worksheet
Set Ws = Worksheets("Sheet1")
Ws.Rows.Hidden = False
Dim keyWord(0 To 1) As String
Dim colm(0 To 1) As Long
keyWord(0) = Range("C1")
colm(0) = 2 'B列
Dim Rng As Range
Dim objColm As Range
Set objColm = Rows(3).Find(Range("E1").Text)
If Not objColm Is Nothing Then
colm(1) = objColm.Column
keyWord(1) = "〇" '〇は文字種があります
Set Rng = rowsHidden(keyWord, colm)
Else
MsgBox "列が見つかりません": Exit Sub
End If
'アドレスコピー
If Not Rng Is Nothing Then
Rng.Copy Worksheets("Sheet2").Range("A1")
Else
MsgBox "該当データがありません"
End If
Ws.Rows.Hidden = False
End Sub

Function rowsHidden(keyWord() As String, colm() As Long) As Range
Dim Rng As Range
Dim i As Long
For i = 4 To Cells(Rows.Count, 1).End(xlUp).Row
If InStr(Cells(i, colm(0)).Value, keyWord(0)) > 0 _
And InStr(Cells(i, colm(1)).Value, keyWord(1)) > 0 Then
Rows(i).Hidden = False '解除済みなので不要？
If Rng Is Nothing Then
Set Rng = Cells(i, "D")
Else
Set Rng = Union(Rng, Cells(i, "D"))
End If
Else
Rows(i).Hidden = True
End If
Next
Set rowsHidden = Rng
End Function

・・・やっぱりフィルターを使った方が良いと思います
その方が記録も出来るし分かりやすいかと・・・・