[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『マクロ 複数ブックの値を1ブックに纏める』（VBA初心者 Manna）
ファイルの所在を検索し、検索された在り処（ハイパーリンク付）から、
ファイルを特定し、そのF列の値を別ファイルにコピーさせたい。
①親フォルダ内に4つの子フォルダがあります。
②子フォルダ内には、140ファイル（xls）あります。
③ファイル名は101_○○○.xls～240_○○○.xlsです。
今、出来ていること。
「ファイルの検索＆ファイル名」取得マクロは出来ました。
が、それ以上の事が全く分かりません…
（仮に子フォルダをA,B,C,Dとします）
Aフォルダ内のみを指定して、F8：F57の値をコピーさせる事は出来ました。
が、それだと、Aフォルダ内に存在しないファイルのF列は、#REF!と表示されてしまい、
面倒な事になっています。（140もファイルがあると…）
Bフォルダを検索させると、Aフォルダで更新されたファイルの値が#REF!になってしまいます…
どうにか、検索をかけた「所在フォルダのアドレスとファイル名」から、
ファイルを指定して、F8：F57の値を別ファイルにコピーするマクロは出来ないでしょうか？
現状纏めのエクセルはこんなMatrix風になっています。
A B C D E F …列
ファイル名 101 102 103 104 105 106
求めたい値 OK OK NG OK NG
↓ NG OK NG OK OK
↓ OK OK NG OK OK
↓ OK OK NG NG OK
よろしくお願いします。
－－－－－－－－－－－－－－－－
Sub ファイル所在検索()
Dim vntF As Variant
Dim objFS As FileSearch
Dim objFSO As FileSystemObject
Dim dteDate As Date
Dim GYO As Long
Dim cntFound As Long
Set objFS = Application.FileSearch ' FileSearch
Set objFSO = New FileSystemObject ' FSO
Rows("5:65536").ClearContents
GYO = 4
With objFS
.NewSearch
.LookIn = Trim(Cells(1, 2).Value) ' Search開始フォルダ
.Filename = Trim(Cells(2, 2).Value) ' 探索ファイル式
dteDate = DateAdd("m", Cells(3, 2).Value * -1, Date)
.SearchSubFolders = True ' サブフォルダも探索
' 処理開始
If .Execute() <> 0 Then
' 見つかったファイル分のループ
For Each vntF In .FoundFiles
'－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
' ↓↓↓この間が見つかったファイルに対する処理↓↓↓
' FSOにてファイルを取得
With objFSO.GetFile(vntF)
' 今回は、最終更新日を確認し、該当ならシートの表示
If .DateLastModified >= dteDate Then
GYO = GYO + 1
Cells(GYO, 1).Value = _
Left(.Path, Len(.Path) - Len(.Name) - 1)
cntFound = cntFound + 1
Cells(GYO, 2).Value = .Name
Cells(GYO, 3).Value = .DateLastModified
End If
End With
' ↑↑↑この間が見つかったファイルに対する処理↑↑↑
'－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Next vntF
End If
End With
Set objFS = Nothing
Set objFSO = Nothing
' 処理結果の表示
If cntFound = 0 Then
MsgBox "見つかりません"
Else
MsgBox cntFound & "個見つかりました"
End If
End Sub
－－－－－－－－－－－－－－－－
(質問者：Manna)
すみません、追加情報です。
親フォルダは、会社のネットワークドライブ上にあります。
(質問者：Manna)
理解が悪く･･･ (^^; >Aフォルダ内のみを指定して、F8：F57の値をコピーさせる事は出来ました >Aフォルダ内に存在しないファイルのF列は、#REF!と表示されてしまい Ａフォルダ内を検索しているのになぜ、存在しないブックがあるのか？ シートレイアウトを改善すれば良いような気もしますが･･･
一度シートレイアウト（表形式）を提示して、どうしたいかを説明してした方が良いのでは？ マクロありきの説明になってしまって必要な情報が抜けているようです。
>.LookIn = Trim(Cells(1, 2).Value) ' Search開始フォルダ >.Filename = Trim(Cells(2, 2).Value) ' 探索ファイル式 とありますが、このブック、シート、セルについての説明がありません。 （aaa.xls に検索したいフォルダとブック名の一覧があり･･･ 見たいな...）
(1or8)
説明の仕方が悪かったです、すみません。
「まとめのエクセルブック」は、5シート構成です。
Sheet1…進捗＆担当者一覧
Sheet2…101～240チェック_詳細結果
Sheet3…301～440チェック_詳細結果
Sheet4…501～640チェック_詳細結果
Sheet5…ファイル所在検索を求めるためのシート
上記の「Sheet2…101～240チェック_詳細結果」にマクロを入れたいのです。
現状、このようになっています。
A B C D E F G H …列
ファイル名→→ 101 102 103 104 105 106 …
求めたい値 1 OK OK NG OK NG
↓ 2 NG OK NG OK OK
↓ 3 OK OK NG OK OK
↓ 4 OK OK NG NG OK
(行)
※列…ファイル名
※行…各ファイルのF8:F57に表示される値
※C列には、101_○○○.xlsのF8:F57の値をコピーしたいです。
D列には、102_○○○.xlsのF8:F57の値をコピーしたいです。
仕事で、ある機器の検証をしています。
検証テストをするときに使用するファイルが、「Aフォルダ」に140ファイルあります。
（ファイル名「101_○○○.xls～240_○○○.xls」）
↓
検証テストは、1ファイルずつ複数人で行います。
↓
検証テストが終了したファイルは、Aフォルダから「B・C・Dフォルダ」のいずれかに切り取り移動されます。
↓
ということで、移動されてしまったファイルは、Aフォルダ内を検索しても、#REF!と表示されてしまう訳です…
（今、自分で書いていて最初の質問の際に、どれだけ省略したかが分かりました…＾＾；）
※A,B,C,Dフォルダは、同フォルダ内、同階層にあります。
※何かできないかと考えて、追加したマクロが「ファイル所在検索」のマクロです。
※Aフォルダ内のファイルは、最終的に0になります。
※各ファイルがA・B・C・Dフォルダのいずれに保存されているかは「ファイル所在検索マクロ」を実行しないと分かりません。
今、考え付く所で、情報はコレくらいです。
よろしくお願いします！
(質問者：Manna)
1or8さんの目を盗んで・・・・ こんなコードはどうでしょう。
列は・・・C列からに成ったんですね。 でも、行は分からなかったので、2行目からにしておきました。 C1の「101」を先頭に EL1の「140」まで、間が飛ぶことなく 順番に番号が入っていると決め付けて、列の確認はしていません。 なお、マクロを実行するブック「まとめのエクセルブック.xls」は ４つのフォルダと同じ階層にいることを想定しています。
'------
Sub まとめ()
Dim iFol As Long, myCol As Long, flg As Long
Dim myFile As String, myPath As String
Dim arFol
'↓実際のフォルダ名に変更
arFol = Array("A", "B", "C", "D") 'フォルダを増やしたい場合は、ここに追記
With Workbooks("まとめのエクセルブック.xls") '←実際のブック名に変更
For iFol = 0 To Application.CountA(arFol) - 1
myPath = .path & "\" & arFol(iFol) & "\"
myFile = Dir(myPath, vbNormal)
If myFile <> "" Then
flg = 0
Do
myCol = Left(myFile, 3) - 98
If 3 <= myCol And myCol <= 142 Then '↓実際のシート名に変更。開始行もここで指定
With Sheets("101～240チェック_詳細結果").Cells(2, myCol)
.Formula = "='" & myPath & "[" & myFile & "]" & "Sheet1'!F8"
.Copy .Resize(50)
.Resize(50).Value = .Resize(50).Value
End With
myFile = Dir()
Else
flg = 1
End If
Loop Until myFile = "" Or flg = 1
End If
Next
End With
End Sub
'------
それぞれのフォルダの各ブック名の上３文字から 98を引いた結果が3(C)～142(EL)の間に入る時に 各ブックのF8:F57の値を転記します。
シート名が「101～240チェック」だったので 同じフォルダに241以上がある場合を想定して ＞100を引いた結果が３(C)～142(EL)の間に入る時に の処理を入れています。 必要なければ削除してもらってよいと思います。
ちなみに、文頭に半角スペースを入れると 改行がそのまま表示できますよ。 _←この部分に半角スペースが入っています。
(HANA)
1or8さんの目を盗んで・・・・ 笑えました…＾＾
･･･････････ところが、なのです（泣）
私が全然理解しておらず、申し訳ないのですが… 実は、101ファイルのF8:F57を、まとめエクセルブックのD10：D60に 102ファイルのF8:F57を、まとめエクセルブックのE10：E60に と言う風に、コピーさせたいのです。 このような形式↓↓ -------------------------------------------------------------------- （列） A B C D E F G （行) 7 分類 状態 放置 8 シートNo. 101 102 103 104 9 部材名 操作 － － － － 10 OK OK OK OK 11 OK NG OK OK 12 （↓10～60行目まで別ファイルの値をコピー↓）
-------------------------------------------------------------------- そして、求めたいブックのシート名は、各ブック名と同じに変更してあります。 （Sheet1ではないです…） ※まとめのエクセルブックは4つのフォルダと同階層に保存してあります。
【私が実行したこと】 ①頂いたコードを丸コピー。 ②A,B,C,Dを実際のフォルダ名に変更。 ③"まとめのエクセルブック.xls"も実際のブック名に変更。 ④分かる範囲で、開始行・開始列・シート名も変更しました。
しかし、ウンともスンとも言わず… 何が悪いのでしょう…
>ちなみに、文頭に半角スペースを入れると >改行がそのまま表示できますよ。 >_←この部分に半角スペースが入っています。 はじめ、この記述は何を教えてくれているのだろう？？？ と思いましたが、私がコメントを書くときに苦労したのが分かって頂けたのですね。 何から何まで教えていただき、本当にありがとうございます！
(質問者：Manna)
せっかく1or8さんの手柄を横取りしようと思っていましたのに 動きませんか・・・。 それでは、確認して頂きたい事と質問です。
確認して頂きたい事は ＞親フォルダは、会社のネットワークドライブ上にあります。 と言う事ですので、 コードの状況にフォルダやブックやシート名をあわせた物を用意し まずはご自身のパソコン内で動くかどうか確認して下さい。 希望通りに動くようなら、ネットワーク上に置いて 再度確認して下さい。
質問は ＞求めたいブックのシート名は、各ブック名と同じに変更してあります。 と言う事ですが、各ブックの中には目的のシート以外にも シートが有りますでしょうか？
以上２点です。
(HANA)
完全にお任せしてます ^^ヾ し～ましぇん m(__)m (1or8)
To,1or8さん
＞完全にお任せしてます ^^ヾ えぇぇっ・・・。（汗） まぁ、安心しておいて下さい。 いざとなったら、丸投げしますので。 その時は、ちゃんとキャッチして下さいね。
(HANA)
＞親フォルダは、会社のネットワークドライブ上にあります。 と言う事ですので、 コードの状況にフォルダやブックやシート名をあわせた物を用意し まずはご自身のパソコン内で動くかどうか確認して下さい。 希望通りに動くようなら、ネットワーク上に置いて 再度確認して下さい。
デスクトップに移動させ、コードに合わせたフォルダ・ブック・シートを 用意しました。 確認中ですので、しばしお待ち下さい。
質問は ＞求めたいブックのシート名は、各ブック名と同じに変更してあります。 と言う事ですが、各ブックの中には目的のシート以外にも シートが有りますでしょうか？
目的のシート以外、何もありません。
HANAさん、1or8さん、ご迷惑おかけしますが、よろしくお願いします。
(質問者：Manna）
With Sheets("101～240").Cells(2, myCol)
この位置で、「実行時エラー'9’：インデックスが有効範囲にありません」と表示されてしまいます…
これは、きっとマクロに書いたコードのシート名と実際のシート名が異なるって事ですよね？
(質問者：Manna）
＞これは、きっとマクロに書いたコードのシート名と実際のシート名が異なるって事ですよね？ 次の様なコードで確認してみるのはどうでしょう。
A1セルに、マクロに書いたコードのシート名を貼り付けて下さい。
このシートをアクティブにした状態で
↓のコードを実行。
Sub シート名確認()
If ActiveSheet.Name = Range("A1").Value Then
MsgBox "同じです"
Else
MsgBox "違います"
Range("B1").Value = ActiveSheet.Name
End If
End Sub
違う場合は、実際の名前がB1セルに表示されるので 確認して下さい。
ちなみに・・・やっぱり気になるので・・・ コメント記入の際は、その都度ご署名をお願いします。
(HANA)
ぎゃ～…失礼しました！！ そして、ありがとうございますm(_ _)m そうですよね、署名は当たり前の礼儀ですよね、本当に失礼しました。
頂きましたコードでシート名が確認できました。 全く違うシート名を記入しておりました…
ということで、出来ました！！！ 本当に、ありがとうございます。 びっくりするほど、手早く作動してくれているので、本当に嬉しいです。 色々とご指導いただき、ありがとうございました。
(Manna)
＞全く違うシート名を記入しておりました… ・・・何処のシート名を入れていたのでしょう？ これは、今後の参考のためにもし宜しければ教えて下さい。
何れにせよ、出来たようで。良かったです。 ちなみに ＞求めたいブックのシート名は、各ブック名と同じに変更してあります。 ＞（Sheet1ではないです…） この部分の変更も出来ましたかね？
(HANA)
全く違うシート名は… 求めたいブックのシート名（101.○○○～240．○○○）を入れていました…（初歩的なミスですみません）
求めたいブックのシート名が変更されていても、Sheet1のままのコードでOKでした！ （140の各ブックにシートが1つしかなかったからですかね？）
マクロは奥が深いですね！ 本当に、もっともっと勉強したい！と思いました。
HANAさん、1or8さん、色々とありがとうございました。 初めて質問させていただいたのですが、とってもとってもよい先生に恵まれた事に感謝です。
(質問者：Manna)
うぅ～ 私は何もしていない･･･
(1or8)
済みません、 ＞同じフォルダに241以上がある場合を想定して 書いていた部分に不具合が有りました。
またSheet1の件はやはり ＞（140の各ブックにシートが1つしかなかったからですかね？） と言うことの様なので、この部分も変更しました。
ブック名と同じ（全角半角等含め）シートが無い場合でも 上記理由から、シートが１枚しかない場合は問題有りませんが シートが複数有る場合で、シート名とブック名が違っていた場合は どのシートの値を参照するか確認が出ます。 その場合は、シート名を確認してください。
フォルダ名、ブック名、シート名をそれぞれ変更してください。 （表示する行列番号は、修正済みです。）
'------
Sub まとめ()
Dim iFol As Long, myCol As Long
Dim myFile As String, myPath As String
Dim arFol
'↓実際のフォルダ名に変更
arFol = Array("A", "B", "C", "D") 'フォルダを増やしたい場合は、ここに追記
With Workbooks("まとめのエクセルブック.xls") '←実際のブック名に変更
For iFol = 0 To Application.CountA(arFol) - 1
myPath = .path & "\" & arFol(iFol) & "\"
myFile = Dir(myPath, vbNormal)
If myFile <> "" Then
Do
myCol = Left(myFile, 3) - 97
If 3 < myCol And myCol < 144 Then '↓実際のシート名に変更。開始行もここで指定
With Sheets("101～240チェック_詳細結果").Cells(10, myCol)
.Formula = "='" & myPath & "[" & myFile & "]" & Replace(myFile, ".xls", "'!F8")
.Copy .Resize(50)
.Resize(50).Value = .Resize(50).Value
End With
End If
myFile = Dir()
Loop Until myFile = ""
End If
Next
End With
End Sub
'------
(HANA)
HANAさん！！！すごい！！！すごい！！ 今、新しく作って頂いたコードを入れて走らせてみました！ 完璧です。
こんなに丁寧に教えて頂けるなんて、本当に感激です。 今までは、関数を入れて、マクロの記録をさせて… という途方もなく長い時間をかけていた私なので、ビックリという言葉しか出てこないです。
うぅぅ…なんて親切な方がいるんだろう。本当にありがとうございます。 ここ1週間ほど、悩みに悩んで出来なかった事なので（夢にまで出る程でした…） 本当に、嬉しいです。
1or8さん、何もしていないって事はないです！ 書き込んでくれて、きちんと見守ってくれてただけでも、本当に心強かったです。
HANAさん、本当に本当に、ありがとうございました。 私の質問に丁寧かつ親切に教えて頂き、そして、色々なルール＆マナーを学べて 幸せです。
(質問者：Manna）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.