テーブル抽出結果を別シートに抽出

質問

＊画像を添付し忘れたので、もう一度同じ質問をします。
画像のようなサンプルがあるとします。
「契約者リスト」にテーブルが設定されていて、フィルタで抽出した人の氏名が全員分、「契約抽出」に抽出されるようにするためにはVBAでどうすれば良いですか？もし、仕様上無理なことならはっきり無理とお願いします。

例えば、4月契約を抽出すると熊谷武久、横山美波、小峰頼子、石渡葵衣、柿崎一正が該当するので、この4名の氏名が転記されます。これを一度設定すると7月更新を抽出すると柿崎一正、小倉優芽が自動的に転記されるようにしたいです。

回答No.11

山田 太郎（@f_a_007） · ベストアンサー

【お節介がてらに・・・】

　質問者の目論見を超簡単に実現するには、先ずは、《基本情報管理シート》を用意すべきだと思います。で、その雛形を作成してみました。で、次に、その《基本情報管理シート》を《レポート》に変換。この変換は、やってみると割と簡単でした。一度もExcelの操作経験がない私にも可能でした。

【原則】各種集計は、《基本情報管理シート》の情報を基に行うべし。

　今回の試みの混乱の原因は、この《集計は、基本情報基づくべし！》という原則を無視して、二次的な《レポート》から各種集計を行おうとしていることです。

　添付図の上の表（=基本情報）から二次的な《レポート》を作成するのは、Excelの専売特許。なら、これに挑戦したらいかがかな。ただし、その場合、【顧客ID】という考えの不可する必要があります。同姓同名の”鈴木　一郎”さんもいますから。ただ、これは、契約書のどこかに書かれているのを採用すればよいと思います。

　て、ことで、先ずは、テーブル設計の再検討が先決ではないでしょうか？《基本情報管理テーブル》とその《レポート》という基本に立ち返られたらどうでしょうか？これですと、前期契約者の当月更新リストの作成も可能。もちろん《レポート》から作成するのではなくて、《基本情報管理テーブル》から作成する訳ですが・・・。

以上、お節介でした。

お礼

ご回答ありがとうございます。
他の回答もあわせて考えた結果、設計を少し改めたうえで、教えていただいたことの組み合わせで実現できるめどがつきました。

回答No.10

山田 太郎（@f_a_007）

【訂正】

X 期首契約情報を表示する先頭列が必要なんじゃーないですか？
O 契約現在情報を表示する先頭列が必要なんじゃーないですか？

　で、現契約者の当月更新者を抜き出したい。ただし、この場合にも疑問が、更新するのお客様は現契約者のみ。ですから、契約現在情報は必ずしも不可欠ではない。ってことは、橙色だけを抜き出したいってことかな。だとすれば、橙色のSQL文で目的達成です。

お礼

ご回答ありがとうございます。
他の回答もあわせて考えた結果、設計を少し改めたうえで、教えていただいたことの組み合わせで実現できるめどがつきました。

回答No.9

山田 太郎（@f_a_007）

【補足】回答8を読んで・・・

フムフム。確かにおかしい。
添付図の橙色だけを抜き出しているの１番目。
添付図の赤色だけを抜き出しているの２番目。
両方を抜き出しているのが３番目。

? DSelect("Select 名前 From [Sheet1$A2:J9] Where 契約='〇' And 更新2='〇'")
顧客2
? DSelect("Select 名前 From [Sheet1$A2:J9] Where 契約1='〇' And 更新2='〇'")
顧客5
? DSelect("Select 名前 From [Sheet1$A2:J9] Where (契約='〇' Or 契約1='〇') And 更新2='〇'")
顧客2;顧客5

【疑問：なぜ、期首契約情報がないのか？】

過去の回答のSQL文はかなり適当でしたので、多少、質問の主旨に沿って修正。が、その過程で、何をやりたいのかが分からなくなりました。仮に、期首が５月だとすると、どうやって抜き出すのですか？そういう意味では、期首契約情報を表示する先頭列が必要なんじゃーないですか？

と、同じ疑問を抱いたので・・・

お礼

ご回答ありがとうございます。
他の回答もあわせて考えた結果、設計を少し改めたうえで、教えていただいたことの組み合わせで実現できるめどがつきました。

回答No.8

SI299792

「小倉優芽」は４月契約していません。
４月契約と７月更新を選択すると、「柿崎一正」だけが残ると思うのですが。どうしてでしょうか。

フィルターをかけてあるので、単に手作業でフィルターで、
４月契約７月更新に○が付いているものを選んでコピペすればいいと思うのですが。
どこまでVBA でやりたいのでしょうか。

フィルター操作を手作業でして、コピーだけしたいのであれば、
'
Sub Macro1()
'
　　Sheets("抽出結果").UsedRange.Clear
　　ActiveSheet.UsedRange.Copy [抽出結果!A1]
　　Sheets("抽出結果").Select
End Sub
とすればいいです。（契約者リストを開いているのが前提です。）
でもこれでは、手作業とほとんど差がありません。

フィルター操作もマクロでやる場合、選択する項目ををどうやって指定するかが問題になります。ユーザーフォームを使う以外思い付きませんでした。そうなるとマクロを入れるだけではできません。以下からダウンロードしてやってみて下さい。データ便は３日で消えます。

参考URL：

http://dtbn.jp/IMRiMRm

お礼

ご回答ありがとうございます。
他の回答もあわせて考えた結果、設計を少し改めたうえで、教えていただいたことの組み合わせで実現できるめどがつきました。

回答No.7

山田 太郎（@f_a_007）

【補足】関数の案内・・・その３

　GetFieldName()で列名を取得出来たってことは、同じ要領で行データも取得できるってことです。

【イミディエイトウインドウ】
? DSelect("SELECT * FROM [Sheet1$A2:G9]")
顧客1;;;;;;;顧客2;〇;;;;;;顧客3;〇;;;;;;顧客4;;;;;;;顧客5;;;;〇;;;顧客6;;;;〇;;;顧客7;;;;;;
? DSelect("SELECT * FROM [Sheet1$A2:G9]",,chr(13))
顧客1;;;;;;
顧客2;〇;;;;;
顧客3;〇;;;;;
顧客4;;;;;;
顧客5;;;;〇;;
顧客6;;;;〇;;
顧客7;;;;;;

　最初は、行区切り子を指示していません。ですから、全てのデータが列区切り子で連結されています。これは、これでリストボックスのレコードソースのセットをする際に必要なことです。だが、そうでない場合には、行区切り子を指定します。テストでは、chr(13)を指定して改行させています。

《条件付きで検索するには？》
? DSelect("SELECT * FROM [Sheet1$A2:G9] WHERE 契約='〇'",,chr(13))
顧客2;〇;;;;;
顧客3;〇;;;;;

《条件付きで名前を検索するには？》
? DSelect("SELECT 名前 FROM [Sheet1$A2:G9] WHERE 契約='〇'",,chr(13))
顧客2
顧客3

Public Function DSelect(ByVal strSQL As String, _
　　　　　　　　　　　　Optional colDelimita As String = ";", _
　　　　　　　　　　　　Optional rowDelimita As String = ";", _
　　　　　　　　　　　　Optional xlFileName As String = "", _
　　　　　　　　　　　　Optional isHeader As Boolean = True) As String
On Error GoTo Err_DSelect
　　'
　　' 【要参照設定】
　　'
　　' Micrsoft ActiveX Data Objects 2.8 Library
　　'
　　Dim R　　　　　 As Integer ' 行インデックス
　　Dim N　　　　　 As Integer ' 行総数 - 1
　　Dim cnn　　　　 As ADODB.Connection
　　Dim rst　　　　 As ADODB.Recordset
　　Dim fld　　　　 As ADODB.Field
　　Dim strList　　 As String　' 全てのデータを区切子で連結して格納

　　Set cnn = New ADODB.Connection
　　Set rst = New ADODB.Recordset
　　'
　　' ThisWorkbook.FullName の指定
　　'
　　If Not Len(xlFileName) Then
　　　　 xlFileName = ThisWorkbook.FullName
　　End If
　　'
　　' 接続設定
　　'
　　With cnn
　　　　.Provider = "Microsoft.ACE.OLEDB.12.0"
　　　　If isHeader Then
　　　　　　.Properties("Extended Properties") = "Excel 12.0;HDR=YES;IMEX=1"
　　　　Else
　　　　　　.Properties("Extended Properties") = "Excel 12.0;HDR=NO;IMEX=1"
　　　　End If
　　　　.Open xlFileName
　　　　'
　　　　' 列を読み込み
　　　　'
　　　　With rst
　　　　　　.Open strSQL, cnn, adOpenKeyset, adLockReadOnly
　　　　　　If Not .BOF Then
　　　　　　　　N = CInt(.RecordCount) - 1
　　　　　　　　.MoveFirst
　　　　　　　　For R = 0 To N
　　　　　　　　　　For Each fld In .Fields
　　　　　　　　　　　　With fld
　　　　　　　　　　　　　　strList = strList & .Value & colDelimita
　　　　　　　　　　　　End With
　　　　　　　　　　Next fld
　　　　　　　　　　strList = Mid(strList, 1, Len(strList) - 1) & rowDelimita
　　　　　　　　　　.MoveNext
　　　　　　　　Next R
　　　　　　Else
　　　　　　　　strList = ""
　　　　　　End If
　　　　End With
　　End With
Exit_DSelect:
On Error Resume Next
　　rst.Close
　　Set rst = Nothing
　　DSelect = IIf(Len(strList) > 0, Replace(strList & "[END]", rowDelimita & "[END]", ""), "")
　　Exit Function
Err_DSelect:
　　MsgBox "SELECT 文の実行時にエラーが発生しました。(DSelect)" & Chr(13) & Chr(13) & _
　　　　　　"・Err.Description=" & Err.Description & Chr(13) & _
　　　　　　"・SQL Text=" & strSQL, _
　　　　　　vbExclamation, " 関数エラーメッセージ"
　　Resume Exit_DSelect
End Function

PS、列を読み込むコードの書き方

　上では、For-Nextで読み込んでいます。その際 RecordCountがLongLong型に変更されたのでCInt()でキャストしています。これが気に喰わないという向きもあるでしょう。そういう時は、次の書き方に変更されてください。

　　' ----------------------------------------
　　'　レコードセット　オープン
　　' ----------------------------------------
　　With rst
　　　　.Open strSQL, cnn
　　　　If Not .BOF Then
　　　　　　.MoveFirst
　　　　　　Do
　　　　　　　　For Each fld In .Fields
　　　　　　　　　　With fld
　　　　　　　　　　　　strList = strList & .Value & colDelimita
　　　　　　　　　　End With
　　　　　　　　Next fld
　　　　　　　　strList = Mid(strList, 1, Len(strList) - 1) & rowDelimita
　　　　　　　　　　 .MoveNext
　　　　　　Loop Until (.EOF)
　　　　Else
　　　　　　strList = ""
　　　　End If
　　End With

　ここまでで、今回の案件は、VBAを書かなくても、紹介の関数を式に書くだけで達成できるかと思います。もう一つだけ、DLookup()という関数があれば、総件数、総額、平均値、最大値、最小値、あるいは単純な検索の全てを簡単に実現できます。ど紹介したいところですが、質問とは無関係ですので割愛します。

　さて、後は、冒頭で述べた仕掛けの実現です。ここまでも説明で達成できますでしょうか？無理だがしたい！というのであれば補足されてください。

お礼

ご回答ありがとうございます。
他の回答もあわせて考えた結果、設計を少し改めたうえで、教えていただいたことの組み合わせで実現できるめどがつきました。

回答No.6

山田 太郎（@f_a_007）

【補足】関数の案内・・・その２

　HohoPapaさんの回答のように、質問者のテーブルの列名は一意のそれではありません。ですが、その場合、ADODBは、各列名を一意のそれに変換して処理します。では、どのように変換しているのでしょうか？そもそもがヘッダーが無い場合には、いかなる列名でADODBは処理しているのでしょうか？SQL言語での処理を試みる場合に、最初に困惑するのがこの問題です。で、いい加減な列名を指示すると《パラメータがありません》というエラーを発生させることになります。そこで、必須とも言えるのがGetFieldName()です。

　先ずは、GetFieldName()でADODBが使用している列名を参照してみます。

【イミディエイトウインドウ】
? GetFieldName("SELECT * FROM [Sheet1$A2:G9]")
名前;契約;更新;解約;契約1;更新1;解約1;
? GetFieldName("SELECT * FROM [Sheet1$A1:G9]")
F1;4月;F3;F4;5月;F6;F7;
? GetFieldName("SELECT * FROM [Sheet1$A1:G9]",,,False)
F1;F2;F3;F4;F5;F6;F7;

　結果、次のことが分かります。

１、重複している列名は番号が付与して区別している。
２、４番目の引数で《ヘッダー無し》をしてすると・・・
　　F1、F2・・・・Fnの列名を用いている。
３、結合列ではF1、F2と付与する番号は飛ぶ。

　いずれにしろ、不確かな場合には、GetFieldName()で確認されることをお勧めしておきます。

　さて、GetFieldName()は、次のようなものです。これも、1999年に書いたもののExcelバージョンに過ぎません。

第二引数：区切り子を指定する
第三引数：エクセルのワークブックを指定する
第四引数：ヘッダーの有無を指定する

　第三引数でエクセルのワークブックを指定しないと、ThisWorkbook.FullNameをオープンします。また、ヘッダーの有無で《False 》を明示的に指定しなきゃー”有り”と判断します。

　HohoPapaさんの回答のようにADODBをObject宣言してADODBでキャスト（？）する書き方もあります。それをしない場合には、[ツール(T)]-[参照設定]で《 Micrsoft ActiveX Data Objects 2.8 Library》にレ点を入れてください。もちろん、HohoPapaさん方式に書き換えられるのであれば、その必要はありません。

　　'
　　' 【要参照設定】
　　'
　　' Micrsoft ActiveX Data Objects 2.8 Library
　　'

Public Function GetFieldName(ByVal strSQL As String, _
　　　　　　　　　　　　　　 Optional colDelimita As String = ";", _
　　　　　　　　　　　　　　 Optional xlFileName As String = "", _
　　　　　　　　　　　　　　 Optional isHeader As Boolean = True) As String
On Error GoTo Err_GetFieldName
　　'
　　' 【要参照設定】
　　'
　　' Micrsoft ActiveX Data Objects 2.8 Library
　　'
　　Dim cnn　　　　 As ADODB.Connection
　　Dim rst　　　　 As ADODB.Recordset
　　Dim fld　　　　 As ADODB.Field
　　Dim strList　　 As String　' 全てのデータを区切子で連結して格納

　　Set cnn = New ADODB.Connection
　　Set rst = New ADODB.Recordset
　　'
　　' ThisWorkbook.FullName の指定
　　'
　　If Not Len(xlFileName) Then
　　　　 xlFileName = ThisWorkbook.FullName
　　End If
　　'
　　' 接続設定
　　'
　　With cnn
　　　　.Provider = "Microsoft.ACE.OLEDB.12.0"
　　　　If isHeader Then
　　　　　　.Properties("Extended Properties") = "Excel 12.0;HDR=YES;IMEX=1"
　　　　Else
　　　　　　.Properties("Extended Properties") = "Excel 12.0;HDR=NO;IMEX=1"
　　　　End If
　　　　.Open xlFileName
　　　　'
　　　　' 列を読み込み
　　　　'
　　　　With rst
　　　　　　.Open strSQL, cnn, adOpenKeyset, adLockReadOnly
　　　　　　If Not .BOF Then
　　　　　　　　.MoveFirst
　　　　　　　　For Each fld In .Fields
　　　　　　　　　　With fld
　　　　　　　　　　　　strList = strList & .Name & colDelimita
　　　　　　　　　　 End With
　　　　　　　　Next fld
　　　　　　Else
　　　　　　　　strList = ""
　　　　　　End If
　　　　End With
　　End With
Exit_GetFieldName:
On Error Resume Next
　　rst.Close
　　cnn.Close
　　Set rst = Nothing
　　Set cnn = Nothing
　　GetFieldName = IIf(Len(strList) > 0, strList, "")
　　Exit Function
Err_GetFieldName:
　　MsgBox "SELECT 文の実行時にエラーが発生しました。(GetFieldName)" & Chr(13) & Chr(13) & _
　　　　　　"・Err.Description=" & Err.Description & Chr(13) & _
　　　　　　"・SQL Text=" & strSQL, _
　　　　　　vbExclamation, " 関数エラーメッセージ"
　　Resume Exit_GetFieldName
End Function

お礼

ご回答ありがとうございます。
他の回答もあわせて考えた結果、設計を少し改めたうえで、教えていただいたことの組み合わせで実現できるめどがつきました。

回答No.5

山田 太郎（@f_a_007）

【補足】関数の案内・・・その１

　SQL言語での回答がありましたので、もう少し、案件毎にVBAを書かないやり方について補足しておきます。その為には、先ずは、標準ライブラリに最低で３つの関数を登録しておく必要があります。その筆頭は、CutStr()です。

　VBEを開いて、[挿入(I]-[標準モジュール]をクリックして以下のコードをコピペします。

Option Explicit

Public Function CutStr(ByVal Text As String, _
　　　　　　　　　　　　ByVal Separator As String, _
　　　　　　　　　　　　ByVal N As Integer) As String
　　Dim strDatas() As String

　　If N > 0 Then
　　　　strDatas = Split("" & Separator & Text, Separator, , 0)
　　　　CutStr = strDatas(N * Abs(N <= UBound(strDatas)))
　　End If
End Function

　DIM文を除けば、僅かに4行の関数です。ただ、VBA初心者の方には、直ちには理解出来ないかも知れません。が、理解される必要はありません。同関数は、1999年に作成したものです。その後、今日に至る使用実績があります。ですから、関数ユーザは利用方法さえ知っていれば十分です。それを知るには、先ずは、VBEで[表示(v)]-[イミディエイトウインドウ(I)]をクリックして[イミディエイトウインドウ]を表示して以下のテストを行われることです。

【イミディエイト】
? CutStr("名前1;名前2;名前3", ";", 1)
名前1
? CutStr("名前1;名前2;名前3", ";", 2)
名前2
? CutStr("名前1;名前2;名前3", ";", 3)
名前3
? CutStr("名前1;名前2;名前3", ";", 4)

? CutStr("名前1;名前2;名前3", ";", 0)

? CutStr("名前1;名前2;名前3", ";", -1)

　このように、CutStr()を用いる際には３つの引数を指定します。一番目が、対象の文字列。二つ目が、区切り子。三つめが、何番目を取り出すのか？３つしかないのに４番目を指示、あるいは0番目とか-1番目を指示すると空文字が返ってきます。

【イミディエイト】
? CutStr("This is a pen.", " ", 1)
This
? CutStr("This is a pen.", " ", 2)
is
? CutStr("This is a pen.", " ", 3)
a
? CutStr("This is a pen.", " ", 4)
pen.
? CutStr(CutStr("This is a pen.", " ", 4), ".", 1)
pen
? CutStr("This is a pen.", " is ", 1)
This
? CutStr("This is a pen.", " is ", 2)
a pen.

　CutStr()は、区切り子を指定できますので、" "で区切って取り出すことも、" is "と任意も文字列で区切って取り出すことも可能。更に、ネストすることで取り出した文字列"pen."から"."を除去することもできます。

　以上のテストが理解できれば、

　　　　CutStr = strDatas(N * Abs(N <= UBound(strDatas)))

で、何をやっているかは知る必要はありません。

お礼

ご回答ありがとうございます。
他の回答もあわせて考えた結果、設計を少し改めたうえで、教えていただいたことの組み合わせで実現できるめどがつきました。

回答No.4

imogasi

この質問・回答の特徴（VBAなどで扱うとき、複雑にしている点）は、
・SQLでエクセルシートを扱う。あまり質問にも出ない課題。
　SQLといっても、MSがエクセル用に、適応したサービス（仕様）を付け加えている。
　純粋なSQL熟達者（例ORACLEのベテラン）でも、VBAの熟練者でも、この点は、初めは勉強が必要。
　この点に慣れる必要がある。
　もし、普通のVBAで、行データに対し繰り返し処理をする方法なら
　困難点はまだ少ない。
・シートがテーブル設定（最近新設された仕様）がなされている
・列の見出し文言に、月ごとの重複がある。同じ「契約」が２か所以上。
・セル結合を用いている箇所がある。月分を見やすくするため。
・データが月ごとに別列になっている。
・シート見出し的な行がある（第１行）
ーー
テーブル設定を手動操作で外して（VBAでもできると思うが）
例データ
シート名はSheet1のまま。
ーー
A1:G１２
シート名：契約者リスト
2018年4月 2018年5月　以右列（６月以後）は略
名前 契約 更新 解約 更新 解約
熊谷 〇
川井 ーーー〇
鹿島 〇
横山 〇
小峰 〇
石渡 〇
柿崎 〇
志田 　ーーー 〇
笹原 　－－－ 〇
小倉 　－－－ 〇
木下 　ーーー 〇
北村 　ーーー 〇
森野 　－－－ 〇
ーーー
標準モジュールに
下記はWEBにあるコード例を持ってきて、修正し、自分への注意メモを、コメントとして入れています。
また、参照設定が必要です。
上記では、列見出しがユニークでなく、フィールド名として使えないので、HDRはNoとし、フィールド名はF1,F2,・・を使う。
ーーーー
Sub ADOJetOLEDB() 'OK
' **************************************************************
' Summary:ADO と Microsoft Jet OLE DB 4.0 プロバイダを使用して、
' Excelシートに接続する
' **************************************************************
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strFilePath As String
Dim strFileName As String
On Error GoTo Err_Handler
' Sheet1のデータをクリアする
With Sheets("Sheet1").Range("a1:G65536")
.ClearContents
.Interior.ColorIndex = xlNone
End With

' ファイルパスを指定する
'strFilePath = "C:\temp\"

' ファイル名を指定する
'strFileName = "売上.xls"

' 面倒なのでファイルパス＋ファイル名にする
strFileName = "C:\Users\XXXXXXXXXXXXXXX.xlsm"
Application.ScreenUpdating = False
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strFileName & ";" & _
"Extended Properties=""Excel 12.0;HDR=NO;"";"
'OLEDBProvider ・・・ Excel2007以降で作成したブックに接続する場合は、
'Microsoft.ACE.OLEDB.12.0;、Excel2002/2003で作成したブックに接続する場合は、
'Microsoft.Jet.OLEDB.4.0; を指定します。
'----
'Extended Properties に指定する各プロパティ値について
'・Excel 12.0 の部分は、データベースの種類を表しています。Excel2007以降で作成したブックに接続する場合は、Excel 12.0、Excel2002/2003で作成したブックに接続する場合は、Excel 8.0 を指定します。
'・HDR は、シートの１行目をフィールド名として扱うかどうかを指定します。No を指定した場合、フィールド名は、F1、F2、F3 のように F[列番号] で表示されます
'----
' rs.Open "SELECT * FROM [Sheet1$]", cn, _
' adOpenStatic, adLockOptimistic, adCmdText
'---OK
rs.Open "SELECT F1,F2,F5 FROM [Sheet1$] where f2=""〇"" or F5=""〇""", cn, adOpenStatic, adLockOptimistic, adCmdText
' シート「Sheet1」のB2に貼り付けます。
ThisWorkbook.Sheets("Sheet1").Range("B2").CopyFromRecordset rs

' オブジェクトの破棄
rs.Close: Set rs = Nothing
cn.Close: Set cn = Nothing
Application.ScreenUpdating = True
Exit Sub
Err_Handler:
Application.ScreenUpdating = True
MsgBox CStr(Err.Number) & Err.Description
End Sub
素晴らしいのは、CopyFromRecordset rsの部分だと思う。一発（コード１行）でシートデータになる。
上記のSELECT文が、個別・固定的で、相対化・汎用化してないので、質問者には、物足りないかも。
６月以後も対象にするには、SQLを書き換えないといけないなどの点が欠点。
そういう点から、参考程度の回答と思ってください。
まあ結論は、上記のように、SQLを使うやり方に、深入りしない方がよいと思った。
ーー
結果
４，５月の契約者名を出したもの。
熊谷 〇
川井 ーーー〇
横山 〇
小峰 〇
石渡 〇
柿崎 〇
志田 ーーー〇
笹原 ーーー〇
小倉 ーーー〇
北村 ーーー〇
森野ーーー〇

お礼

ご回答ありがとうございます。
他の回答もあわせて考えた結果、設計を少し改めたうえで、教えていただいたことの組み合わせで実現できるめどがつきました。

回答No.3

HohoPapa

ごめんなさい、訂正します。

「契約抽出」はシート名ですね？
更にこのシートのA1セルに年月が埋まっている。
A2セル以下に抽出結果を書き出す。
という条件でよければ、
以下のコードでいかがでしょうか？

Option Explicit

Sub Sample2()

　Const PutShName = "契約抽出"
　Const SLine = 4　'検索開始行
　Const MaxColCnt = 128　'想定最大列数
　Dim RowCnt As Long
　Dim RowNum As Long
　Dim ColCnt As Long
　Dim ColNum As Long
　Dim GetShe As Worksheet
　Dim PutShe As Worksheet

　Set GetShe = ThisWorkbook.Sheets("契約者リスト")
　Set PutShe = ThisWorkbook.Sheets(PutShName)

　'集計側列番号を求める
　ColNum = 1
　Do
　　ColNum = ColNum + 1
　　If MaxColCnt < ColNum Then Exit Do
　　If GetShe.Cells(3, ColNum).Value = _
　　　 PutShe.Cells(1, 1).Value Then Exit Do
　Loop

　'集計側列番号が見つからなかったら
　If MaxColCnt < ColNum Then
　　MsgBox ("該当列無し")
　　Exit Sub
　End If

　'リストアップ
　RowCnt = SLine
　RowNum = 1
　Do
　　If GetShe.Cells(RowCnt, 1).Value = "" Then Exit Do
　　If GetShe.Cells(RowCnt, ColNum).Value = "〇" Then
　　　RowNum = RowNum + 1
　　　PutShe.Cells(RowNum, 1).Value = _
　　　　GetShe.Cells(RowCnt, 1).Value
　　End If
　　RowCnt = RowCnt + 1
　Loop

End Sub

また、
「契約抽出」はシート名ですね？
更にこのシートのA1セルに契約1とか、更新3など、
契約者リストの3行目の列名を埋め
A2セル以下に抽出結果を書き出す。
という条件でよければ、
以下のコードでいかがでしょうか？

Sub Sample3()

　Dim cn As Object
　Dim rs As Object
　Dim wkSQL As String

　'抽出列名特定
　Dim ColNme As String

　ColNme = ThisWorkbook.Sheets("契約抽出").Cells(1, 1).Value

　Set cn = CreateObject("ADODB.Connection")
　Set rs = CreateObject("ADODB.Recordset")
　cn.Provider = "Microsoft.ACE.OLEDB.12.0"
　cn.Properties("Extended Properties") = "Excel 12.0;HDR=YES;IMEX=1"
　cn.Open ThisWorkbook.FullName

　'SQL文組み立て
　wkSQL = ""
　wkSQL = wkSQL & "SELECT [名前] " & vbCrLf
　wkSQL = wkSQL & "FROM [契約者リスト$A4:L65000]" & vbCrLf
　wkSQL = wkSQL & "Where [" & ColNme & "] = '〇'" & vbCrLf

　'SQL文実行
　rs.Open wkSQL, cn

　'結果セットを格納
　ThisWorkbook.Sheets("契約抽出").Cells(2, 1).CopyFromRecordset rs

　'後処理
　rs.Close
　Set rs = Nothing
　cn.Close
　Set cn = Nothing

End Sub

お礼

ご回答ありがとうございます。
他の回答もあわせて考えた結果、設計を少し改めたうえで、教えていただいたことの組み合わせで実現できるめどがつきました。

回答No.2

HohoPapa

「契約抽出」はシート名ですね？
更にこのシートのA1セルに年月が埋まっている。
A2セル以下に抽出結果を書き出す。
という条件でよければ、
以下のコードでいかがでしょうか？

Option Explicit

Sub Sample()

　Const PutShName = "契約抽出"
　Const SLine = 4　'検索開始行
　Const MaxColCnt = 128　'想定最大列数
　Dim RowCnt As Long
　Dim RowNum As Long
　Dim ColCnt As Long
　Dim ColNum As Long
　Dim GetShe As Worksheet
　Dim PutShe As Worksheet

　Set GetShe = ThisWorkbook.Sheets("契約者リスト")
　Set PutShe = ThisWorkbook.Sheets(PutShName)

　'集計側列番号を求める
　ColNum = 1
　Do
　　ColNum = ColNum + 1
　　If MaxColCnt < ColNum Then Exit Do
　　If GetShe.Cells(3, ColNum).Value = _
　　　 PutShe.Cells(1, 1).Value Then Exit Do
　Loop

　'集計側列番号が見つからなかったら
　If MaxColCnt < ColNum Then
　　MsgBox ("該当列無し")
　　Exit Sub
　End If

　'リストアップ
　RowCnt = SLine
　RowNum = 1
　Do
　　If GetShe.Cells(RowCnt, 1).Value = "" Then Exit Do
　　If GetShe.Cells(RowCnt, ColNum).Value = "〇" Then
　　　RowNum = RowNum + 1
　　　PutShe.Cells(RowNum, 1).Value = _
　　　　GetShe.Cells(RowCnt, 1).Value
　　End If
　　RowCnt = RowCnt + 1
　Loop

End Sub

※SQL文を投げて抽出する対応も考えられますが
Ｂ列以降個々の列に名前がないので、扱いにくく
（3列ごとの名前なので）見送りました。

※VBAでの解を期待していることから
掲示しました。
VBAのイロハは理解されている前提です。

お礼

ご回答ありがとうございます。
他の回答もあわせて考えた結果、設計を少し改めたうえで、教えていただいたことの組み合わせで実現できるめどがつきました。

回答No.1

山田 太郎（@f_a_007）

【再回答】

先の回答と軌を一にした再回答です。

質問者が示した表から指定月の契約者の名前を抽出することは可能です。

? DSelect("SELECT 名前 FROM [Sheet1$A2:G9] WHERE 契約='〇'",,";")
顧客2;顧客3
? DSelect("SELECT 名前 FROM [Sheet1$A2:G9] WHERE 契約1='〇'",,";")
顧客5;顧客6

肝は、抽出条件をパラメータ化することです。

4月‥‥契約='〇'
5月‥‥契約1='〇'

つまり、"SELECT ‥‥契約" & [セルの値] "='〇'" とすればよいと言う事。後は、

顧客2;顧客3
顧客5;顧客6

などの検索抽出した名前を

CutStr(検索抽出した名前リストの存在するセル名, ";", 1)
CutStr(検索抽出した名前リストの存在するセル名, ";", 2)
‥‥
CutStr(検索抽出した名前リストの存在するセル名, ";", n)

という要領で表示することになります。

PS、Excelの関数で同じことを実現できませんか？

私は、Excelに関する知識はゼロ。ですから、DSelect()、CutStr()というAccessで使っていた関数のExcelバージョンをもって対応するしかありません。が、この場合も、VBAでプログラミングする必要はありません。DSelect()、CutStr()を式に書くだけです。

お礼

ご回答ありがとうございます。
他の回答もあわせて考えた結果、設計を少し改めたうえで、教えていただいたことの組み合わせで実現できるめどがつきました。