[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複数のフォルダにある同名ファイルからデータを抽出』（momo）
OSはWindowsXP、Excelは2010です。
複数のフォルダに「元データ.xls」というファイルがあります。
このいくつもある「元データ.xls」の1シート目（Sheet1）にあるデータを、それぞれ抽出して新たなExcelファイルにまとめたいのですがどうしたらいいでしょうか？
1シート目にあるデータは一つ（1行）のものもあれば、20（20行）あるものもあります。
列はどれもAからSまであります。
よろしくお願いします。
複数のフォルダは、どこにあるんだろう？ 本当に、パソコンの様々な場所にてんでばらばらにあるのかな？ それとも、ある場所にサブフォルダとして集まっているのかな？
(ぶらっと)
フォルダはCドライブにあります。
まず、2009、2010、2011、2012といった年数のフォルダがあり、その中年数のフォルダにさらに「あ」「い」「う」といったぐあいに顧客名のフォルダがあります。
肝心の「元データ.xls」のファイルはその各顧客名のフォルダに入っています。
どの顧客ファイルにも同じ「元データ.xls」ファイルがあります。
「元データ.xls」の中にはシートが2つあり、その最初にシートは「データフォーム」といシート名でその中に取り出したいデータがあります。
最初の1行目はタイトル行で、実際のデータは2行目からになります。
よろしくお願いします。
それでは、一例ということで。 マクロ内でシートが１枚だけの新規ブックが生成される。
Sub Sample()
Dim stPath As String
Dim yyFold As Object
Dim csFold As Object
Dim bkName As String
Dim bkPath As String
Dim fso As Object
Dim yrBook As Workbook
Dim myBook As Workbook
Dim cnt As Long
Dim z As Long
Application.ScreenUpdating = False
stPath = "c:\"
bkName = "元データ.xls"
Set fso = CreateObject("Scripting.FIleSystemObject")
For Each yyFold In fso.getfolder(stPath).subfolders
If IsNumeric(yyFold.Name) Then
For Each csFold In yyFold.subfolders
bkPath = csFold.Path & "\" & bkName
If fso.FileExists(bkPath) Then
Set yrBook = Workbooks.Open(bkPath)
cnt = cnt + 1
If cnt = 1 Then '最初
yrBook.Sheets(1).Copy
Set myBook = ActiveWorkbook
Else
With myBook.Sheets(1).UsedRange
z = .Cells(.Cells.Count).Row + 1
End With
With yrBook.Sheets(1)
.Range("A1", .UsedRange).Offset(1).Copy myBook.Sheets(1).Range("A" & z)
End With
End If
yrBook.Close False
End If
Next
End If
Next
Application.ScreenUpdating = True
If cnt > 0 Then
MsgBox "統合完了"
Else
MsgBox "指定ブックは１件もありませんでした"
End If
End Sub
(ぶらっと)
私が十分説明できてないところがあれば教えてください。
Sub Test()
myPath = ThisWorkbook.Path & "\"
fname = Dir(myPath & "*.xls") 'フォルダ内のExcelファイルを検索します
Do Until fname = Empty '全て検索し終えると、fname = Empty となるので、その間以下を実行します
If fname <> ThisWorkbook.Name Then
Workbooks.Open myPath & fname '選択したファイルを開きます
Set AB = ActiveWorkbook
lr = ThisWorkbook.Sheets("Sheet1").Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
On Error Resume Next
AB.Sheets("データフォーム").UsedRange.Copy
On Error GoTo 0
ThisWorkbook.Activate
Sheets("Sheet1").Range("A" & lr + 1).Select
ActiveSheet.Paste
AB.Close
End If
fname = Dir '選択したフォルダ内の次のExcelファイルを検索します
Loop
End Sub
> ただ、「指定ブックは１件もありませんでした」と出てきてしまいました。
質問文では「元データ.xls」とありましたがが、実際は「元ファイル.xls」であるとか。でしたら、どこを修正すればよいか･･･
> 必要ない1行目のタイトル行も全部引っ張ってきてしまいます
ぶらっとさんのコードだと、cnt=1のとき（最初）と、2つ目のファイル以降とで処理を変えていませんか？
(マナ)さん、フォロー深謝。
ということで、（momo） さん、がんばってみよう。 にっちもさっちもいかなくなったら ＳＯＳ 出してくれればお手伝いする。
念のため、メモ。
(マナ)さんの指摘のように、アップしたコードは ・最初のブックからは、タイトル行も持ってくる。 ・次のブックからは、２行目から持ってくる（タイトルはもってこない）
こんな仕掛けにしている。これを最初のブックも２行目から持ってくるようにするのは だぶん、（momo） さんもできると思うけど、それ以外に 最初のブックで、統合用の新規ブックを作成し、２番目のブックからは【作成済み】のブックに書き込んでいるので そのあたりを注意してくれたらいいね。
ところで、こちらがアップしたコード、インデントを付けた【普通の】書き方にしているんだけど そちらのコードは全行、１列目からコードが始まってるね。 好き好きだといわれればおしまいだけど、インデントはちゃんとつけたほうがいいよ。
(ぶらっと)
>以下でやってみたんですが、必要ない1行目のタイトル行も全部引っ張ってきてしまいます。
あぁ、そうか。必要ないタイトル行を持ってきているというのは (momo)さんがアップした Testプロシジャでやると、そうなるということ？
そちらの Testプロシジャは、本件のテーマとして説明もらった要件は全く考慮されていなし また、こちらがアップした【部分的な要素】のみを切り出したテストツールでもないし なぜ、Testプロシジャの形でテストしたのか、意図がわからないんだけどね。
まぁ、それはそれとして、Testプロシジャでは、
AB.Sheets("データフォーム").UsedRange.Copy としているのでタイトル行もすべてコピーされて
後続のペーストで反映してしまうからだけどね？
それと、実際にはこれで問題ないとは思うけど、ブックによって、たとえばＡ列が（なぜか）空白列だったら UserRangeはＢ列からになって、それがまとめシートのＡ列からペーストされるので、列がずれてきちゃう。
一応、こちらでアップしたものは、そういうことがあっても列がずれないようにしている。
(ぶらっと)
で、肝心の、こちらでアップしたコードで、ブックがひっかからず空振りする件、(マナ)さんの指摘のことも含めると
・実際のブック名がコードで規定したブック名ではない。
・Cドライブの下のフォルダ階層は２階層。
で、Cドライブ内のフォルダを全部対象にするとちょっと多すぎるので、最初の階層のフォルダは
フォルダ名が【数字】というしばりにしている。
それ以外のフォルダは相手にされない。
・で、その【数字】フォルダの中のサブフォルダを探して、その中に、指定の名前のブックがあるかどうかを
チェックしている。
つまり、【数字】フォルダ直下にブックがあってもそれは抽出対象にはならない。
原因としては、これぐらい。
ステップ実行って知ってるかな？ ＶＢＥ画面の Sample プロシジャの任意の場所をマウスでクリックしたうえでF8を、どんどん押していくと コードが１行ずつ実行される。 こうして、どこで空振りして抜けているのか、確認するのが早道だっと思うよ。
(ぶらっと)
全然初心者なので、わからないまま、いろいろ試したりして失礼なやり方や返信の仕方をしていたら本当にすみません。
＞ ステップ実行って知ってるかな？
＞ＶＢＥ画面の Sample プロシジャの任意の場所をマウスでクリックしたうえでF8を、どんどん押していくと
＞ コードが１行ずつ実行される。
＞ こうして、どこで空振りして抜けているのか、確認するのが早道だっと思うよ。
知りませんでしたが、とても役に立ちますね！早速確認してみます。
ぶらっとさんとマナさんに教えていただいたことをこれから一つずつよく読んで、やり直してみようと思います。
上手くいかなかったらまた教えていただくことになると思いますがよろしくお願いします。
ひとまずは丁寧なご教授本当にありがとうございました。
がんばってやってみます！
（momo）
原因はやはりお二人のお見立てどおり、私の間違いでした。
ぶらっとさんの「・Cドライブの下のフォルダ階層は２階層」を見て、今一度確認しました。
そうしたら、3階層になっているフォルダがあることがわかりました。
2階層になるように移動させたら、うまくいきました！
お忙しいのにご対応いただき本当にありがとうございました。
（momo）
それらのフォルダだけ、別のフォルダに移して一行目から引っ張ってくるようにしようと思いますが、
この「Row + 1」の部分を変更すればいいのでしょうか。
Else
With myBook.Sheets(1).UsedRange
z = .Cells(.Cells.Count).Row + 1
End With
（momo）
ちがいますよ〜。
z = .Cells(.Cells.Count).Row + 1
これは、転記先の（つまりまとめさきの）行。今あるデータ最大行の次の行から転記という +1 。
抽出側の２行目からというコードは
.Range("A1", .UsedRange).Offset(1).Copy myBook.Sheets(1).Range("A" & z)
ここ。
.Range("A1", .UsedRange).Offset(1)
この Offset(1) が１行目を除いた２行目からを意味している。
なので、１行目からコピーするなら
.Range("A1", .UsedRange).Copy myBook.Sheets(1).Range("A" & z)
こうなるね。
(ぶらっと)
ありがとうございました。
（momo）
また通常と違うものが出てきてしまいました。
探すファイルは「元データ.xls」の名前だったはずですが、「元データ」の前に「N20120105」といった文字と数字の組み合わせがついているものがいくつか出てきました。
引っ張ってくるデータのファイル名を「元データ」を含む、という風にしたいのですが、以下のようにしたのではうまくいきませんでした。こんな単純なことではできませんよね．．．
stPath = "c:\"
bkName = "*元データ.xls"
どのようにしたら「“元データ”がファイル名に含まれている」と表現できるのか教えてください。
よろしくお願いします。
（momo）
なんとか元データ.xls だけ？ 元データなんとか.xls といったものとか なんとか元データなんとか.xls といったものは？
で、アップ済みのコードは、そのフォルダに１つだけある元データをピックアップしているけど、 この 元データを含むブックがフォルダ内に複数ある場合は、それらすべてをもってくる？ それとも、最初に見つかったものだけもってくる？
いずれにしても、コードをがらっとかえる必要があるので、上記、回答よろしく。
(ぶらっと)
回答です。
ファイル名は「なんとか元データ.xls 」だけです。でも、「元データ」だけのもあるので、できれば「なんとか元データ.xls 」と「元データ.xls 」の両方を引っ張ってくるようにしたいです。
あと、フォルダには基本的に一つしかないはずですが、2つ入っているものもあるようです。ですので、複数ある場合は全てもってきたいです。
ほんとに何から何まですみません。
コードががらっと変わるんですね。何かを追加とか変更でできると思ってた自分の甘さに反省です。
ぶらっとさんにおんぶに抱っこですみません。よろしくお願いします。
（momo）
それでは・・・・
ワイルドカードが登場するので、DIR関数やDIRコマンドが適していると思い、だから コードをがらっと・・・と考えたけど、ちょっと気力がなくなったので、非効率だけど 現行のＦＳＯをベースにした構成のまま。
以前、コードをアップした際には、簡単なテスト環境を作って確認したんだけど、もう、すっかり消し去っているので 以下のコードは、動かしていない。バグあれば指摘してね。
元データ.xls も、なんとか元データ.xls も、元データなんとか.xls も、なんとか元データなんとか.xls も とにかく、あるだけもってくる。
Sub Sample2()
Const CKNAME As String = "*元データ*"
Dim stPath As String
Dim yyFold As Object
Dim csFold As Object
Dim csBook As Object
Dim fso As Object
Dim yrBook As Workbook
Dim myBook As Workbook
Dim cnt As Long
Dim z As Long
Dim myExt As String
Dim myBase As String
Application.ScreenUpdating = False
stPath = "c:\"
Set fso = CreateObject("Scripting.FileSystemObject")
For Each yyFold In fso.GetFolder(stPath).subfolders
If IsNumeric(yyFold.Name) Then
For Each csFold In yyFold.subfolders
For Each csBook In csFold.Files
myExt = fso.GetExtensionName(csBook.Name)
myBase = fso.GetBaseName(csBook.Name)
If LCase(myExt) = "xls" And csBook.Name Like CKNAME Then
Set yrBook = Workbooks.Open(csBook.Path)
cnt = cnt + 1
If cnt = 1 Then '最初
yrBook.Sheets(1).Copy
Set myBook = ActiveWorkbook
Else
With myBook.Sheets(1).UsedRange
z = .Cells(.Cells.Count).Row + 1
End With
With yrBook.Sheets(1)
.Range("A1", .UsedRange).Offset(1).Copy myBook.Sheets(1).Range("A" & z)
End With
End If
yrBook.Close False
End If
Next
Next
End If
Next
Application.ScreenUpdating = True
If cnt > 0 Then
MsgBox "統合完了"
Else
MsgBox "指定ブックは１件もありませんでした"
End If
End Sub
(ぶらっと)
非効率でも私にとっては十分です！！
前のコードを使ってくださっているので、どこを変更したのかわかりやすいです。
一つ一つ比べていって勉強させて頂きます。ありがとうございました。
もし途中で動かないところがあったらまた助けてください。
ひとまずお礼まで！！
（momo）
多分もう問題は出てこないはずですが．．．．また出てきてどうしても自分で解決できない場合はまた教えてください。
ぶらっとさんの適確な回答で本当に助かりました。
ぶらっとさんみたいにスラスラとコードが書けるようになりたいです．．．多分無理と思いますが。
本当にありがとうございました。
感謝、感謝です！
（momo）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.