Access2000VBA・Excel2000VBA独学～複数のシートのリスト形式の表を、好きな列や行を抜き出して縦に結合し、1つの転記先シートにまとめるサンプルプログラム（ADO＋SQL）～複数のファイルの同じレイアウトの表を縦にまとめたいときにも、作り変えれば行けると思います。～ | 無駄なお金と時間がない方・零細企業様・独立したい方・個人事業主の方・営業さん・経理さん・学生さん・就活生さん・小学生のお子様、中高生の子たちのための、　　　　「小さな会社の兼任なんちゃって社内SE・パソコン管理術・の基礎知識」

Access2000VBA・Excel2000VBA独学～複数のシートのリスト形式の表を、好きな列や行を抜き出して縦に結合し、1つの転記先シートにまとめるサンプルプログラム（ADO＋SQL）～複数のファイルの同じレイアウトの表を縦にまとめたいときにも、作り変えれば行けると思います。～
　　
※まだ書きかけです。すみません。
※間違ってたらすみません。
※メモ書きなので、自分でも意味不明な箇所も多いです。ごめんなさい。
　　
　　
目次
　★ ご注意
　★ 「日本のExcelでのデータ管理」の「無駄の多さ」と、本サンプルの関係性について
　★ はじめに（想定シーンなど）
　★ その他の想定シーン
　★ 前提条件
　★ 必要な列や行を抜きだすための条件を書き換えるには
　★ 他のブックを読みに行くには？
　★ SQLの「UNION ALL（縦結合命令）」を使わなかった理由
　★ 他のブックを読みに行ったときに、2013以降でエラーが出る場合
　★ サンプルプログラム（コメントなし）
　★ サンプルプログラム（コメントあり）
※Shift＋TABキー、もしくは、Homeキー、Homeキー＋TAB数回、を押すと、目次付近に戻れます。
　　
　　
★ ご注意

このサンプルは、「SQL」のほかに、「ADO」と呼ばれる機能も使っていますが、以下のWebページに書かれているような「参照設定」という設定をしないと動きません。

『ExcelでADO・ADODBへの参照設定を』
https://www.relief.jp/docs/excel-vba-referencing-to-adodb-library.html

なので、かならずこの設定をしてからお試しください。

※2.5から大丈夫なので、Excel2000でも大丈夫だと思います。
　　
　　

★ 「日本のExcelでのデータ管理」の「無駄の多さ」と、本サンプルの関係性について

大変失礼かつ無礼な言い方になってしまって、特にお若い方々には本当に申し訳ございませんが、本記事のこのような処理は、本来はVBAなんか使わなくても・・・・

「最初から、1つのブックの1つのシートに、時系列に下に・下に・ひたすら下方向に、データを蓄積していれば、” やらなくて済む ”、” 本当に愚かしい処理 ” 」

・・・・です。

「最初から、1つのブックの1つのシートに、時系列に下に・下に・ひたすら下方向に、データを蓄積してさえいれば、本記事のサンプルプログラムのようなことは1文字も書かなくていい！」んです。

「本記事のサンプルプログラムは、本来、書く必要のない ” 超ムダなプログラム ” 」なんです。

「一回やったら、もう二度とやるな！というくらいの、 ” 超ムダなプログラム ” 」なんです。

しかし、現実には、こういうことをやりたい方が今も後を絶ちません。
（Excelが発売された20年も前から今まで。）

そう教えられてしまうからです。

でも、こんな処理はほんとう、「データ管理の基礎を何も知らない人・効率化のことやコストのことを何も考えない人（特に講師）」がやることです。

なので、本サンプルのような処理をしたあとは、「ソースのブックは全部捨てて」、ただひたすら、新しく１つにまとめたブックのほうに、その後も継続して、時系列に下に・下に・ひたすら下方向に、データを蓄積していくことを「強く・強く・強く・強く」、お勧めします。

でも大変残念ながら、日本の市販書籍は、本サンプルのような処理を「自慢げ」に行います・行わせようとします。そしてこのような処理を何度も行うことを推奨します。
「こんなのVBAで簡単にできるよ！」みたいに。
とてつもない無駄な作業になってしまいますので、どうかご注意ください。
（多くの支店のデータを集める場合、やむをえないかもしれませんが・・・）

「お若い方々の未来が潰されて」かねず、心配になってしまいます。

ExcelVBAの独学者、初心者の方は、このことを是非、忘れないようにしてください。

そして特に「独立したい方」は、「ご自分自身が」、その「そういった迷惑な人たち」にならないように十分にお気をつけください。
「人間性が低い、本質を学ぼうとしない」人間にならないように・・・。
数値管理・接客データ管理に、必要以上に「ムダに」お金をかけすぎるなどといったバカげたことはしないように、どうかご注意ください。
「SQL」や「リレーション」を絶対に勉強してください。
個人レベル、5人以下の事務所なら、システム業者なんかに依頼しなくても、かなり多くのデータが「1回入力しただけで」「何百通りにも」「使いまわし」できます。
VBAやワークシート関数もかなり減らすことができます。
ExcelならMicrosoft Queryという機能やQueryTableオブジェクトで使えます。
本サイトでも関連記事を増やしていきます。

そして、「データの蓄積の仕方」に、是非、興味をもっていただき、今日・今からすぐにでも「1つのブックの1つのシートに、時系列に下に・下に・ひたすら下方向に、データを蓄積していくこと」を始めてみてください。その時のルールは以下の記事にも書いてあります。

『★★★★★★★★★★★★Excelの真の基礎～効率を良くする作表のルール・基本手順（ちょっと詳細版）～Excelやパソコンを単なる紙と電卓の延長としてではなく、真のコンピュータとして使うために～Microsoft Queryやピボットテーブルを使えるようにするために。～』

※その他の参考記事：『動的な表』『静的な表』『SQL』
「時系列に下に・下に・ひたすら下方向に、データを蓄積していく表」→『動的な表』のことです。

このルールは、中高生・・・、下手をしたら小学生でも守れるルールです。
それを大人がやれない、ということは、絶対にありません。

そしてこれを守れば、必ず、今の0.1割増し～ケース・部分によっては10割増し以上の「データ管理の」効率化（コスパアップ、コストダウン）、が図れます。

そちらの方向への展望が開けてきます。
　　
　　

★ はじめに（想定シーンなど）

このプログラムは以下のような処理を想定しています。

(01)「まったく同じ列構成の表」を持つシートが、
(02)例えば1つのExcelファイルの中に30枚以上ある場合で、
(03)そこから任意の列と行を取り出し、新しいシートに縦に結合したい。

そのような場合、例えば「列と行を絞り込む条件」が複雑なものになると・・・・、例えばその処理を「If文やループを使ったプログラム」でおこなってしまうと、とても複雑になってしまいます。

結果、メンテがとても大変になってしまいます。

といいますか、メンテ以前に、（条件がコロコロ変更されるとなると）初版を作るだけでも大変です。

もちろんその後の修正はもっと大変になってしまいます。

・・・というわけで、誰もがある程度簡単に作ったり修正したりできるようにするには、「ループを使わなくて済む」、「SQL」という仕組みが便利だと思いますので、今回は、それを使ってみました。

同時に、「SQLとVBAのCopyFromRecordsetメソッド」を使いたかったので、「ADO」という機能も使っています。これは「DAO」でもイケると思います。

CopyFromRecordsetメソッドは、ADOかDAOの「レコードセット」と呼ばれるものしか扱えないようなので・・・。
　　
　　

★ その他の想定シーン

このサンプルは、「1つのファイルの中で複数のシートを縦にまとめる」ということをしていますが、作り変えれば、「複数のファイルの同じレイアウトの表を縦にまとめたいとき」にも、行けると思います。

参考」『Access2000VBA・Excel2000VBA独学～フォルダの中に含まれる全てのファイルを（全てのサブフォルダの中も全部）再帰的に順に編集するサンプルプログラム～』

その際にも、If文やループで条件設定するのではなく、ADO＋SQLで条件設定して縦に結合するほうが（まとめるほうが）、メンテもラクちんになるケースが多いとは思います。
（もちろん、絶対ではないので、ケースバーケース、ですが。）

★ 前提条件

このプログラムは、自ブックの、2つ目から右への全シート、全行を、「一番左に作った転記先のシート」に転記する設定にしてあります。

なので、一番左に転記先のシートが在る前提です。
（なければ作ります。列名も何もいりません。白紙の状態でOKです。）

そのほか、以下のようなことも前提です。必ずお読みになってください。
でないとエラーになりますが、サンプルなので、エラー対策は何もしていません。

'　※残りのシートはすべて「同じ列構造」であることと、
'　「データがないシートは無い」ということも前提です。
'　　最低限、同じ列名が存在すること。
'　　でないとエラーになります。対策はしてありません。
'
'　　さらには、各ソースシートは、1行目が列名で、
'　　列名の抜けが絶対に無いことも前提です。
'　　もし必要なら、各ソースシートの列名の抜けが無いかを
'　　調べるプログラムを追加します。
'
'　※実際のソースシートの側の列名の末尾に、スペースなどが
'　　隠れていないことも前提です。そのようなミスがあるとエラーで止まります。
'　　その際の対策はしてありません。
'
'　※自ブックではなく、他のブックも一応は読みに行けるように
'　　してありますが、ただし、他のブックのシートを読みに行った時も、
'　　一番左にダミーのシートを作っておくことが必要です。
'　　今のサンプルコードでは、2番目のシートからのすべての
'　　シートを読みに行くかたちになっていますので。
'
'　※バージョン2013以降のSDIには対応していません。
'　　というか、何も考えていません。
'　　なので、もしかしたら、それでも動くかもです。

　　
　　
★ 必要な列や行を抜きだすための条件を書き換えるには

s_SQL01 = "SELECT 連番, 社員番号, 社員名 FROM [" & s_SrcWsNm & "]"

のところだけを、「SQL」というものを調べて書き直せば、指定した条件の行に絞り込みつつ転記できると思います。（行を絞り込むには「Where」や「Between」などの命令語句を使います。）

かなり複雑な条件でもイケます。
そして、ここを書き直すだけでOKです。
その他の箇所をいじる必要はありません。
（ExcelのSQLの「方言」で、テーブル名＝シート名は [　] か、バッククォートで囲む必要があります。また、最後の「;」（セミコロン）が無くても何故か大丈夫な仕様になっています。「$」は「システムテーブル」という意味のようです。）

複雑な条件を、If文やループでやろうと思うと「気が遠くなる」ですが、SQLを使うとそのような「データ管理・プログラミングのムリ・ムダ・ムラ」から解放されることが少なくないので、本当にありがたいです。これを作ってくださった偉大な先人の方々に本当に感謝しないといけません・・・。

このサンプルでは、自ブックの、全シートの「社員番号」列と「社員名」列、「連番」列の、３つの列だけを全行読み込む例です。

列を増やしたかったら、「SELECT」のあとに列名とカンマを使って列の設定を追加します。（「SELECT 」のあとの、「複数の列名の最初と最後」にはカンマを書かないように注意します。）

逆に減らしたかったら、不要な列名とカンマを消します。

また、スペースは、全角スペースを使うとエラーになりますのでそちらもご注意ください。

行を絞り込みたいときは、前述しましたとおり、「SQL」というものを調べて、「Where」や「Between」、その他の命令語句をいくつか使って、絞りこみます。

「SQL」での条件式の詳しい書き方については、SQLに詳しい先輩や同僚の方に聞いてみてください。
　　
　　

★ 他のブックを読みに行くには？

Set o_SrcWb01 = ThisWorkbook
'データを読み込みたい、そのソースとなるブックの設定
' Set o_SrcWb01 = Workbooks.Open("D:\1\縦結合テスト.xlsm")
' Set o_SrcWb01 = Workbooks.Open("\\Fsvr01\Fld01\test.xlsm")

のところに書いたように、
Set o_SrcWb01 = Workbooks.Open("D:\1\縦結合テスト.xlsm")
のように書くか、
もしファイルサーバのファイルでUNCパスが使えるなら、
Set o_SrcWb01 = Workbooks.Open("\\Fsvr01\Fld01\test.xlsm")
のように書いてもいいです。

「Set o_SrcWb01 = ThisWorkbook」の行はコメントアウトします。
　　
　　
★ SQLの「UNION ALL（縦結合命令）」を使わなかった理由
結合したいシートが100枚とか200枚とかあったときに、SQL文が長くなった時に、SQLの側は問題ないのですが、「Excel側が」ちゃんと動くか検証をサボったのでここではやりませんでした。
もし結合したいシートの数が、20か30枚、くらいまでで、それ以上の数は絶対に無い！、ということなら、ループで「UNION ALL（縦結合命令）」を使ったSQLの命令文を作るなどをして、それを使った方が簡単で早いですし、コードも、もっと短くなると思います。
　　
　　

★ 他のブックを読みに行ったときに、2013以降でエラーが出る場合

このサンプルは、バージョン2010で作ったプログラムなので、SDIに対応していません。
なので、2013以降ではいきなりエラーが出るかもしれません。

そうしたらエラーが出たところをご自分で書き換えてみてください。
　　
　　

★ サンプルプログラム（コメントなし）
このサンプルは、かならずこの設定をしてからお試しください。
『ExcelでADO・ADODBへの参照設定を』https://www.relief.jp/docs/excel-vba-referencing-to-adodb-library.html

'
'
Sub ReadByADO01_CopyFromRsPast01()
 
    Dim Cn               As ADODB.Connection
    Dim Rs               As ADODB.Recordset
    Dim o_SrcWb01        As Workbook
    Dim s_SrcWbFlPath    As String
    Dim s_SrcWsNm        As String
    Dim s_SQL01          As String
    Dim o_DistWs01       As Worksheet
    Dim i                As Integer
    Dim j                As Integer
    Dim s_DistCellAddr01 As String
 
    Application.ScreenUpdating = False

    Set o_SrcWb01 = ThisWorkbook
    s_SrcWbFlPath = o_SrcWb01.FullName

    Set Cn = New ADODB.Connection    
    Set Rs = New ADODB.Recordset
 
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
              "Data Source=" & s_SrcWbFlPath & ";" & _
              "Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1;Readonly=False"""
            
    Set o_DistWs01 = ThisWorkbook.Worksheets(1)         
    o_DistWs01.Cells.ClearContents
                                                          
    For i = 2 To o_SrcWb01.Worksheets.Count

        s_SrcWsNm = o_SrcWb01.Worksheets(i).Name & "$"
    
        '★抽出設定。基本、いじるのはここだけ。
        s_SQL01 = "SELECT 連番, 社員番号, 社員名 FROM [" & s_SrcWsNm & "]"
     
        Rs.Open s_SQL01, Cn, adOpenStatic, adLockOptimistic, adCmdText
       
        If i = 2 Then
            For j = 1 To Rs.Fields.Count
                o_DistWs01.Cells(1, j) = Rs.Fields(j - 1).Name
            Next j
        Else
        
        End If

	' ↑上の分岐と合わせればもう少し行数減らせます。
        If i = 2 Then
            s_DistCellAddr01 = "A2"
        Else
            s_DistCellAddr01 = "A" & o_DistWs01.UsedRange.Rows.Count + 1
        End If     
          
        o_DistWs01.Range(s_DistCellAddr01).CopyFromRecordset Rs
        
        Rs.Close
        
    Next i    
    
    Set Rs = Nothing       
    Cn.Close: Set Cn = Nothing      
    
    '他のブックを読みに行った場合は、それを閉じる。
    If o_SrcWb01.FullName <> ThisWorkbook.FullName Then
        o_SrcWb01.Close
    Else
    
    End If     
   
    Application.ScreenUpdating = True
   
 End Sub
'
'

Sub ReadByADO01_CopyFromRsPast01()

Dim Cn As ADODB.Connection

Dim Rs As ADODB.Recordset

Dim o_SrcWb01 As Workbook

Dim s_SrcWbFlPath As String

Dim s_SrcWsNm As String

Dim s_SQL01 As String

Dim o_DistWs01 As Worksheet

Dim i As Integer

Dim j As Integer

Dim s_DistCellAddr01 As String

Application.ScreenUpdating = False

Set o_SrcWb01 = ThisWorkbook

s_SrcWbFlPath = o_SrcWb01.FullName

Set Cn = New ADODB.Connection

Set Rs = New ADODB.Recordset

Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _

"Data Source=" & s_SrcWbFlPath & ";" & _

"Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1;Readonly=False"""

Set o_DistWs01 = ThisWorkbook.Worksheets(1)

o_DistWs01.Cells.ClearContents

For i = 2 To o_SrcWb01.Worksheets.Count

s_SrcWsNm = o_SrcWb01.Worksheets(i).Name & "$"

'★抽出設定。基本、いじるのはここだけ。

s_SQL01 = "SELECT 連番, 社員番号, 社員名 FROM [" & s_SrcWsNm & "]"

Rs.Open s_SQL01, Cn, adOpenStatic, adLockOptimistic, adCmdText

If i = 2 Then

For j = 1 To Rs.Fields.Count

o_DistWs01.Cells(1, j) = Rs.Fields(j - 1).Name

Next j

Else

End If

' ↑上の分岐と合わせればもう少し行数減らせます。

If i = 2 Then

s_DistCellAddr01 = "A2"

Else

s_DistCellAddr01 = "A" & o_DistWs01.UsedRange.Rows.Count + 1

End If

o_DistWs01.Range(s_DistCellAddr01).CopyFromRecordset Rs

Rs.Close

Next i

Set Rs = Nothing

Cn.Close: Set Cn = Nothing

'他のブックを読みに行った場合は、それを閉じる。

If o_SrcWb01.FullName <> ThisWorkbook.FullName Then

o_SrcWb01.Close

Else

End If

Application.ScreenUpdating = True

End Sub

★ サンプルプログラム（コメントあり）
このサンプルは、かならずこの設定をしてからお試しください。
『ExcelでADO・ADODBへの参照設定を』https://www.relief.jp/docs/excel-vba-referencing-to-adodb-library.html

'
'
Sub ReadByADO01_CopyFromRsPast01()
 

 
   '★変数設定
   
    Dim Cn              As ADODB.Connection
    '読込対象のXLSファイルの
    '「ADO接続文字用のオブジェクト」用の変数
    
    Dim Rs              As ADODB.Recordset
    '読込対象のシートの
    '「ADOデータ範囲？設定用のオブジェクト
    '　＝レコードセット」用の変数。
        
    Dim o_SrcWb01      As Workbook
    '読込対象のブック
    'を格納（＝指定）するためのオブジェクト変数

    Dim s_SrcWbFlPath   As String
    '読込対象のXLSファイルの
    'フルパス格納用の変数
    
    Dim s_SrcWsNm       As String
    '読込対象のシート名の格納用の変数
    
    Dim s_SQL01         As String
    'どの列と行をどのように読み込むかの
    'SQL文を格納するための変数
        
    Dim o_DistWs01      As Worksheet
    '読み込んだデータを転記する先のシート
    'を格納（＝指定）するためのオブジェクト変数
    
    Dim i               As Integer
    'ソースのシートのインデックスを
    '格納（＝指定）するための変数

    Dim j                As Integer
    'レコードセットの列のインデックスを
    '格納（＝指定）するための変数
    
    Dim s_DistCellAddr01 As String
    '2つ目以降のソースシートを読み込んだ際に
    'それを転記先シートに書き込むときの、
    'その起点となるセルのアドレスを格納するための変数
    
    
    '▼一応、データが大量だと遅くなってしまうので
    '　画面描画をいったん停止。
    '　デバッグ時などはコメントアウトする。
    
    Application.ScreenUpdating = False
    'Excelの画面描画をいったん停止。
    '今の画面のまま変化させないようにする。
     


    '★以下、メインプログラムです。
 
    Set o_SrcWb01 = ThisWorkbook
    'データを読み込みたい、そのソースとなるブックの設定
'    Set o_SrcWb01 = Workbooks.Open("D:\1\縦結合テスト.xlsm")
'    Set o_SrcWb01 = Workbooks.Open("\\Fsvr01\Fld01\test.xlsm")


    s_SrcWbFlPath = o_SrcWb01.FullName
    'そのブックのフルパスを取得。
    '（以下のような指定も可。）


    Set Cn = New ADODB.Connection
    'ADOにてのデータ接続（＝ファイル内容の読み込み）
    'ができるようにするための準備
    
    
    Set Rs = New ADODB.Recordset
    'ADOにてのレコードセット（＝シート内データ範囲？）が
    '作れるようにするための準備

 
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
              "Data Source=" & s_SrcWbFlPath & ";" & _
              "Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1;Readonly=False"""
    'ADOで読込先のソースファイルに接続。
    '（＝読込先のソースファイルを開く）

        
    
    '▼転記先のシートの内容をいったんクリア
    '　※転記先のシートが一番左にあることが前提です。
    
    Set o_DistWs01 = ThisWorkbook.Worksheets(1)
    '読み込んだデータを転記するシートの設定
         
    o_DistWs01.Cells.ClearContents
    '読み込み先のファイルの列数や行数が増減するといけないので、
    '一応、転記するシートをきれいに空白しておく。
    '前回よりデータ列数や行数が少ないと、
    '前回のデータが残ってしまうので。
                                                            
                                                            
      
      
    '▼転記先のシートへの、各ソースシートの読込み。
    '　※転記先のシートが一番左にあることが前提です。
    '　  また、残りのシートはすべて「同じ列構造」であることと、
    '   「データがないシートは無い」ということも前提です。
    '    さらには、各ソースシートは、1行目が列名で、
    '    列名の抜けが絶対に無いことも前提です。
    '    もし必要なら、各ソースシートの列名の抜けが無いかを
    '    調べるプログラムを追加します。
    '
    '  ※自ブックではなく、他のブックのシートを読みに行った時も、
    '    一番左にダミーのシートが必要です。
    '    今のサンプルコードでは、2番目のシートからのすべての
    '    シートを読みに行くかたちになっていますので。
             
         
    For i = 2 To o_SrcWb01.Worksheets.Count
        '左から2つ目のシートから右へ、残り全部のシートをループ処理します。


        s_SrcWsNm = o_SrcWb01.Worksheets(i).Name & "$"
    '    s_SrcWsNm = "Sheet1$"
        '設定したブックの、
        '読み込むシート（ソースとなるシート）の設定
        '「$」を付けるのは、ExcelでのSQLでの「方言」で、
        '必ずつけます。でないとエラーになってしまいますので・・・・。
        
    
        s_SQL01 = "SELECT 連番, 社員番号, 社員名 FROM [" & s_SrcWsNm & "]"
        '  ↑
        '▼SQL文にて、ソースシートからどの列と行をどのように読み込むかを設定。
        '基本、列名の書き換えだけでOKだと思います。
        'ただし、実際のソースシートの列名の末尾に、スペースなどが
        '隠れていないことが前提です。
        'この例は、全シートの「社員番号」列と「社員名」列、
        '「連番」列の、３つの列だけを読み込む例です。
        '行の指定をしない場合は、全行が読み込まれます。
        
        'なお、セル範囲を指定しない場合は、
        'ソースシート丸ごとのすべての範囲を見に行ってくれて、
        'データが入力されている部分を自動判別してくれて、
        'レコードセットを作ってくれます。
    '    s_SQL01 = "SELECT * FROM [" & s_SrcWsNm & "A1:N15" & "]"
    '    'このようにシート名のあとにセル範囲を追記指定することも可能。
    '    'そこまでの範囲を見に行って、その範囲内で、
    '    'データが入力されている部分を自動判別してくれて、
    '    'レコードセットを作ってくれます。
    
     
        Rs.Open s_SQL01, Cn, adOpenStatic, adLockOptimistic, adCmdText
        'SQL文にて、レコードセットを開く。
        '「レコードセット＝データの入力された範囲？」を
        '決定しつつ。
        

        If i = 2 Then
            For j = 1 To Rs.Fields.Count
                o_DistWs01.Cells(1, j) = Rs.Fields(j - 1).Name
            Next j
            '列名のみ、シートへの転記
            '「HDR=Yes」でデータをレコードセットの取り込んだので、
            '列名は、Rsを貼り付けても貼り付かないため。
        Else
        
        End If
        '↑
        '最初のソースシートを読み込んだ時だけ、
        '列名の転記もします。
        '次のシート以降はしません。レコードのみを転記します。
          
                
        
        If i = 2 Then
            s_DistCellAddr01 = "A2"
        Else
            s_DistCellAddr01 = "A" & o_DistWs01.UsedRange.Rows.Count + 1
        End If
        '↑
        '「次のシートの内容を、転記先シートの
        '　どのセルを起点に転記するか？」、
        '  そのセルのアドレスの設定をします。
        
                
        o_DistWs01.Range(s_DistCellAddr01).CopyFromRecordset Rs
        'CopyFromRecordset にて、転記先のシートに
        'レコードセットの内容を書き出す。
        '「HDR=NO」だと、列名もシートに書き出されるが、
        '「HDR=Yes」はレコードのみとなる。
        ' なお、「HDR=NO」だと、転記後にセルに緑の三角エラーが
        ' 出るが「HDR=Yes」のときは出ない。
        ' 今回は、「HDR=Yes」でやっている。
    
    
        Rs.Close
        '次のソースシートの内容を読み込みたいので、
        'いったんレコードセットの内容をクリアする。
        
    Next i
    
    
    Set Rs = Nothing
    'ループ内で先にCloseしてるので
    'ここではNothingのみをする
'    Rs.Close: Set Rs = Nothing
'    ' 作ったオブジェクトの破棄：
'    '一応メモリリークを起こさないように？
'    '作ったオブジェクトをメモリから消す
    
    
    Cn.Close: Set Cn = Nothing      ' 同上
    
    
    If o_SrcWb01.FullName <> ThisWorkbook.FullName Then
        o_SrcWb01.Close
    Else
    
    End If
    '↑
    'ソースとなるブックが、現在のブックではなくて
    '他のブックだった場合、それを保存せずにそのまま
    '閉じます。
    
    
    '▼Excelの画面描画を再開｡
    
    Application.ScreenUpdating = True
    '画面の変化が普通に表示されるようにする。
   
   
 
 End Sub
 
'
'

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

Sub ReadByADO01_CopyFromRsPast01()

'★変数設定

Dim Cn As ADODB.Connection

'読込対象のXLSファイルの

'「ADO接続文字用のオブジェクト」用の変数

Dim Rs As ADODB.Recordset

'読込対象のシートの

'「ADOデータ範囲？設定用のオブジェクト

'　＝レコードセット」用の変数。

Dim o_SrcWb01 As Workbook

'読込対象のブック

'を格納（＝指定）するためのオブジェクト変数

Dim s_SrcWbFlPath As String

'読込対象のXLSファイルの

'フルパス格納用の変数

Dim s_SrcWsNm As String

'読込対象のシート名の格納用の変数

Dim s_SQL01 As String

'どの列と行をどのように読み込むかの

'SQL文を格納するための変数

Dim o_DistWs01 As Worksheet

'読み込んだデータを転記する先のシート

'を格納（＝指定）するためのオブジェクト変数

Dim i As Integer

'ソースのシートのインデックスを

'格納（＝指定）するための変数

Dim j As Integer

'レコードセットの列のインデックスを

'格納（＝指定）するための変数

Dim s_DistCellAddr01 As String

'2つ目以降のソースシートを読み込んだ際に

'それを転記先シートに書き込むときの、

'その起点となるセルのアドレスを格納するための変数

'▼一応、データが大量だと遅くなってしまうので

'　画面描画をいったん停止。

'　デバッグ時などはコメントアウトする。

Application.ScreenUpdating = False

'Excelの画面描画をいったん停止。

'今の画面のまま変化させないようにする。

'★以下、メインプログラムです。

Set o_SrcWb01 = ThisWorkbook

'データを読み込みたい、そのソースとなるブックの設定

' Set o_SrcWb01 = Workbooks.Open("D:\1\縦結合テスト.xlsm")

' Set o_SrcWb01 = Workbooks.Open("\\Fsvr01\Fld01\test.xlsm")

s_SrcWbFlPath = o_SrcWb01.FullName

'そのブックのフルパスを取得。

'（以下のような指定も可。）

Set Cn = New ADODB.Connection

'ADOにてのデータ接続（＝ファイル内容の読み込み）

'ができるようにするための準備

Set Rs = New ADODB.Recordset

'ADOにてのレコードセット（＝シート内データ範囲？）が

'作れるようにするための準備

Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _

"Data Source=" & s_SrcWbFlPath & ";" & _

"Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1;Readonly=False"""

'ADOで読込先のソースファイルに接続。

'（＝読込先のソースファイルを開く）

'▼転記先のシートの内容をいったんクリア

'　※転記先のシートが一番左にあることが前提です。

Set o_DistWs01 = ThisWorkbook.Worksheets(1)

'読み込んだデータを転記するシートの設定

o_DistWs01.Cells.ClearContents

'読み込み先のファイルの列数や行数が増減するといけないので、

'一応、転記するシートをきれいに空白しておく。

'前回よりデータ列数や行数が少ないと、

'前回のデータが残ってしまうので。

'▼転記先のシートへの、各ソースシートの読込み。

'　※転記先のシートが一番左にあることが前提です。

'　また、残りのシートはすべて「同じ列構造」であることと、

' 「データがないシートは無い」ということも前提です。

' さらには、各ソースシートは、1行目が列名で、

' 列名の抜けが絶対に無いことも前提です。

' もし必要なら、各ソースシートの列名の抜けが無いかを

' 調べるプログラムを追加します。

' ※自ブックではなく、他のブックのシートを読みに行った時も、

' 一番左にダミーのシートが必要です。

' 今のサンプルコードでは、2番目のシートからのすべての

' シートを読みに行くかたちになっていますので。

For i = 2 To o_SrcWb01.Worksheets.Count

'左から2つ目のシートから右へ、残り全部のシートをループ処理します。

s_SrcWsNm = o_SrcWb01.Worksheets(i).Name & "$"

' s_SrcWsNm = "Sheet1$"

'設定したブックの、

'読み込むシート（ソースとなるシート）の設定

'「$」を付けるのは、ExcelでのSQLでの「方言」で、

'必ずつけます。でないとエラーになってしまいますので・・・・。

s_SQL01 = "SELECT 連番, 社員番号, 社員名 FROM [" & s_SrcWsNm & "]"

' ↑

'▼SQL文にて、ソースシートからどの列と行をどのように読み込むかを設定。

'基本、列名の書き換えだけでOKだと思います。

'ただし、実際のソースシートの列名の末尾に、スペースなどが

'隠れていないことが前提です。

'この例は、全シートの「社員番号」列と「社員名」列、

'「連番」列の、３つの列だけを読み込む例です。

'行の指定をしない場合は、全行が読み込まれます。

'なお、セル範囲を指定しない場合は、

'ソースシート丸ごとのすべての範囲を見に行ってくれて、

'データが入力されている部分を自動判別してくれて、

'レコードセットを作ってくれます。

' s_SQL01 = "SELECT * FROM [" & s_SrcWsNm & "A1:N15" & "]"

' 'このようにシート名のあとにセル範囲を追記指定することも可能。

' 'そこまでの範囲を見に行って、その範囲内で、

' 'データが入力されている部分を自動判別してくれて、

' 'レコードセットを作ってくれます。

Rs.Open s_SQL01, Cn, adOpenStatic, adLockOptimistic, adCmdText

'SQL文にて、レコードセットを開く。

'「レコードセット＝データの入力された範囲？」を

'決定しつつ。

If i = 2 Then

For j = 1 To Rs.Fields.Count

o_DistWs01.Cells(1, j) = Rs.Fields(j - 1).Name

Next j

'列名のみ、シートへの転記

'「HDR=Yes」でデータをレコードセットの取り込んだので、

'列名は、Rsを貼り付けても貼り付かないため。

Else

End If

'↑

'最初のソースシートを読み込んだ時だけ、

'列名の転記もします。

'次のシート以降はしません。レコードのみを転記します。

If i = 2 Then

s_DistCellAddr01 = "A2"

Else

s_DistCellAddr01 = "A" & o_DistWs01.UsedRange.Rows.Count + 1

End If

'↑

'「次のシートの内容を、転記先シートの

'　どのセルを起点に転記するか？」、

' そのセルのアドレスの設定をします。

o_DistWs01.Range(s_DistCellAddr01).CopyFromRecordset Rs

'CopyFromRecordset にて、転記先のシートに

'レコードセットの内容を書き出す。

'「HDR=NO」だと、列名もシートに書き出されるが、

'「HDR=Yes」はレコードのみとなる。

' なお、「HDR=NO」だと、転記後にセルに緑の三角エラーが

' 出るが「HDR=Yes」のときは出ない。

' 今回は、「HDR=Yes」でやっている。

Rs.Close

'次のソースシートの内容を読み込みたいので、

'いったんレコードセットの内容をクリアする。

Next i

Set Rs = Nothing

'ループ内で先にCloseしてるので

'ここではNothingのみをする

' Rs.Close: Set Rs = Nothing

' ' 作ったオブジェクトの破棄：

' '一応メモリリークを起こさないように？

' '作ったオブジェクトをメモリから消す

Cn.Close: Set Cn = Nothing ' 同上

If o_SrcWb01.FullName <> ThisWorkbook.FullName Then

o_SrcWb01.Close

Else

End If

'↑

'ソースとなるブックが、現在のブックではなくて

'他のブックだった場合、それを保存せずにそのまま

'閉じます。

'▼Excelの画面描画を再開｡

Application.ScreenUpdating = True

'画面の変化が普通に表示されるようにする。

End Sub

MENU

最近の投稿

カテゴリー

MENU

最近の投稿

カテゴリー

タグ