【VBA】全ての複数シートから指定した列をコピー、新しいブックの１シートに抽出する

図１のような形式のシートが複数シートあります。

行いたいことは、図２のような表を作ることです。
全シートから、図１でいうB列の値だけをコピーし、
新しいブックの１つのシートに"値の貼り付け"をしていきたいです。
二回目以降の貼り付け時には、
コピーしたセルの１つ下のセルから張り付けたいです。

その際、図１の上部にあるシートタイトルやヘッダの部分も、
図２のように分けて表示させたいです。
その他にも、シート名や日付も表示させたいと考えています。
なお、対象ブックのあるパスをセルに入力して
「抽出」等のコマンドボタンをクリックしたら
そのパスを読み込んで抽出処理を行うようにしたいです。

VBAを勉強し始めたばかりでなかなか完成できず困り果てています。
コマンドボタンの配置方法や、クリック時に動作する方法は分かります。
が、セルに入力されたパスを読み込むことに手こずっています。
今まで調べてきたなかで、getPathやgetDirなどを使うんだろうなというイメージですが
動くものを作ることができません。

複数シートが対象なので、for文でシートの終わりまでループを回すことは
想像がつくのですが、実際にコードが書けません。
「こういう考え方で出来る」などでもかまいませんので
何かアドバイスをいただけませんでしょうか。

以上、よろしくお願い致します。

No.1 ベストアンサー 回答者： soixante 回答日時： 2015/11/25 21:14

もう少し詳しく書いたほうがよさそうです。

・図が不鮮明、小さくて読めない
・読み込みたいデータのファイルは一つなのか（一つのファイルに複数シート）、
　複数ファイル（パスを指定した先のフォルダにある全ファイル）なのか、
　で、さらに複数シートなのか
・図2にある日付、元のデータとの関係性が不明。

というわけでざっくりの回答となります。
手作業でやることを考えて書いていってはどうでしょうか。

あくまで一例です。いろいろ組み合わせてみてください。

1) ファイルを開く
　Workbooks.Open FileName:=パス名からのファイル名

２）あるフォルダにある全ファイルを開く
　Dir関数と言うのがあります。
http://officetanaka.net/excel/vba/tips/tips95.htm

たとえば
'---------------------------------------
Sub BBB()
Dim myPath As String, FlNam As String

myPath = "C:\Users\tomoya\Desktop\"
FlNam = Dir(myPath & "*.xlsx")

Do Until FlNam = ""
Workbooks.Open Filename:=myPath & FlNam

FlNam = Dir()
Loop
End Sub
'---------------------------------------

3) あるファイルの全シートをループする
'---------------------------------------
Sub ccc()
Dim k As Integer
For k = 1 To Worksheets.Count
Worksheets(k).Select
Next k

End Sub
'---------------------------------------

4) 最終行を取得する
Dim LstRow As Long
LstRow=Cells(Rows.Count,1).End(xlUp).Row
貼付先は、最終行の次でしょうから、実際には上記に　+1　をするとよいでしょう。


５）B8セルから一番下までの範囲を指定する
Dim Rng As Range
Set Rng =Range(Cells(8,2),Cells(8,2).End(xlDown))

この回答へのお礼

ご回答ありがとうございます。
そして勉強になるコードをたくさん、ありがとうございます。

はい。まずは手作業で、作りたいVBAの細分化をして、どんな機能を持ったプロシジャーが必要なのか等、噛み砕いてみます。
添付図について、ご指摘有難いです。今後画像を一緒に投稿する際は事前にサイズ感等の確認を行います。

読み込みたいデータは（本来は数百ブックあるのですが、まずは”１ブック内の複数シートから抽出する処理”を理解したいので、今回は）パスを指定した先のフォルダにある、１ブックの中の複数シートです。

プログラム内にはパスを書かずに、セルに入力されたパスを読み込むことが目標です。現段階では、以下ように書いています。
psPath = ThisWorkbook.Sheets(”管理”).Cells(1, 2).Value
If Dir(psPath, vbDirectory) = ”” Then
　　MsgBox ”存在しないパスが指定されています。修正してください”
　　Exit Function
End If

最後に日付なのですが、画像だと文字が潰れてしまって確認できないのですが、図１のシートタイトルのすぐ左下（B3）に「2002年7月」とありまして、さらにその左下（A8～A38）に「1から３１」までの日付が下方向にふってあります。
これらから年月日を読み取って、図２のD3のように「2002/7/1」と出力しようとしています。

お礼日時：2015/11/26 10:14