こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

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

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

投稿日時 - 2019-02-09 20:48:00

QNo.9586198

すぐに回答ほしいです

質問者が選んだベストアンサー

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

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

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

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

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

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

以上、お節介でした。

投稿日時 - 2019-02-10 19:40:39

お礼

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

投稿日時 - 2019-02-12 20:32:56

ANo.11

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(11)

ANo.10

【訂正】

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

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

投稿日時 - 2019-02-10 17:26:02

お礼

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

投稿日時 - 2019-02-12 20:33:08

ANo.9

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

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

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

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

投稿日時 - 2019-02-10 17:12:58

お礼

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

投稿日時 - 2019-02-12 20:33:18

ANo.8

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

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

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

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

参考URL:http://dtbn.jp/IMRiMRm

投稿日時 - 2019-02-10 13:51:31

お礼

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

投稿日時 - 2019-02-12 20:33:28

ANo.7

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

 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()という関数があれば、総件数、総額、平均値、最大値、最小値、あるいは単純な検索の全てを簡単に実現できます。ど紹介したいところですが、質問とは無関係ですので割愛します。

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

投稿日時 - 2019-02-10 11:59:34

お礼

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

投稿日時 - 2019-02-12 20:33:44

ANo.6

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

 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;

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

1、重複している列名は番号が付与して区別している。
2、4番目の引数で《ヘッダー無し》をしてすると・・・
  F1、F2・・・・Fnの列名を用いている。
3、結合列では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

投稿日時 - 2019-02-10 11:46:56

お礼

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

投稿日時 - 2019-02-12 20:33:54

ANo.5

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

 SQL言語での回答がありましたので、もう少し、案件毎にVBAを書かないやり方について補足しておきます。その為には、先ずは、標準ライブラリに最低で3つの関数を登録しておく必要があります。その筆頭は、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()を用いる際には3つの引数を指定します。一番目が、対象の文字列。二つ目が、区切り子。三つめが、何番目を取り出すのか?3つしかないのに4番目を指示、あるいは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)))

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

投稿日時 - 2019-02-10 11:42:50

お礼

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

投稿日時 - 2019-02-12 20:34:04

ANo.4

この質問・回答の特徴(VBAなどで扱うとき、複雑にしている点)は、
・SQLでエクセルシートを扱う。あまり質問にも出ない課題。
 SQLといっても、MSがエクセル用に、適応したサービス(仕様)を付け加えている。
 純粋なSQL熟達者(例ORACLEのベテラン)でも、VBAの熟練者でも、この点は、初めは勉強が必要。
 この点に慣れる必要がある。
 もし、普通のVBAで、行データに対し繰り返し処理をする方法なら
 困難点はまだ少ない。
・シートがテーブル設定(最近新設された仕様)がなされている
・列の見出し文言に、月ごとの重複がある。同じ「契約」が2か所以上。
・セル結合を用いている箇所がある。月分を見やすくするため。
・データが月ごとに別列になっている。
・シート見出し的な行がある(第1行)
ーー
テーブル設定を手動操作で外して(VBAでもできると思うが)
例データ
シート名はSheet1のまま。
ーー
A1:G12
シート名:契約者リスト
2018年4月2018年5月 以右列(6月以後)は略
名前契約更新解約更新解約
熊谷〇
川井ーーー〇
鹿島〇
横山〇
小峰〇
石渡〇
柿崎〇
志田 ーーー〇
笹原 ---〇
小倉 ---〇
木下 ーーー〇
北村 ーーー〇
森野 ---〇
ーーー
標準モジュールに
下記は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 は、シートの1行目をフィールド名として扱うかどうかを指定します。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の部分だと思う。一発(コード1行)でシートデータになる。
上記のSELECT文が、個別・固定的で、相対化・汎用化してないので、質問者には、物足りないかも。
6月以後も対象にするには、SQLを書き換えないといけないなどの点が欠点。
そういう点から、参考程度の回答と思ってください。
まあ結論は、上記のように、SQLを使うやり方に、深入りしない方がよいと思った。
ーー
結果
4,5月の契約者名を出したもの。
熊谷〇
川井ーーー〇
横山〇
小峰〇
石渡〇
柿崎〇
志田ーーー〇
笹原ーーー〇
小倉ーーー〇
北村ーーー〇
森野ーーー〇

投稿日時 - 2019-02-10 11:36:06

お礼

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

投稿日時 - 2019-02-12 20:34:15

ANo.3

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

「契約抽出」はシート名ですね?
更にこのシートの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

投稿日時 - 2019-02-10 09:42:50

お礼

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

投稿日時 - 2019-02-12 20:34:32

ANo.2

「契約抽出」はシート名ですね?
更にこのシートの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文を投げて抽出する対応も考えられますが
B列以降個々の列に名前がないので、扱いにくく
(3列ごとの名前なので)見送りました。

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

投稿日時 - 2019-02-10 08:19:00

お礼

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

投稿日時 - 2019-02-12 20:34:43

ANo.1

【再回答】

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

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

? 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()を式に書くだけです。

投稿日時 - 2019-02-09 21:44:52

お礼

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

投稿日時 - 2019-02-12 20:34:56

あなたにオススメの質問