フォルダ内のすべてのブックの値の反映

質問

類似質問を読んでも今ひとつ完全に仕上がらない為、こちらで質問をさせていただいた次第です。
社内の全員がコンピューターに疎く、せめて私が一番マシという状況だったのですが、私のVBAの端っこをかじったくらいでは到底難しい現状です。お力添えいただけますでしょうか。

EXCELは2010です。

誰でも操作できるようにしたい為、ブックにボタンを作成しそのボタンを押すとVBAが実行され、共有上にあるフォルダから、その中にある.xlsのファイルすべて（サブフォルダも含め）のsheet1から、必要な情報だけ抜き取り、新規ブックにリスト化する、という作業をしたいです。（ボタンの作成や、ボタンを押してのVBA実行のあたりは経験がありますので大丈夫だと思います。）

共有上の.xlsのsheet1には決まったひな形のデータがあります。
共有のパスはts-****/share/共有/発注管理　「発注管理」の中にあります。

そこから企業名、支店名、実施店舗名、実施日、担当名、案件進捗状況などだけを抜き取ってリスト化できると非常にありがたいです。

なので、A2から企業名、A3に支店名、A4に担当名、A5に実施日、A6に実施店舗名、A7に案件進捗状況、A8にファイル名、という項目を入れて

それぞれB列から下にそれを反映させていきたいです。
共有上のsheet1にはG5に企業名、G6に支店名、K7に担当名、実施日はG9に初日N9に「～」が入ってP9に終了日が入っている状態でできれば一つのセルに*/*～*/*という表記にしたいです。G10に実施店舗名、X8に案件進捗状況が入っています。

このVBAを実行すればその時フォルダに入っているものが一覧で見ることができる、という事が出来ると非常に作業が効率化できる状況です。

文字ばかりでわかりにくい状況かもしれませんが、ご教授いただけると非常にありがたいです。
よろしくお願いいたします。

回答No.1

High_Score · ベストアンサー

動作確認が出来ない状況ですみません。とりあえず書きました。

Sub Macro1()
Dim i As Long
Dim myPath As String, Flnm As String
ReDim Flnmfp(0) As String
Dim WS1 As worksheet
Set WS1=ThisWorkbook.sheets("sheet1")

myPath="望みのフォルダパスを入力"
Call fpFileName(myPath, Flnmfp ) 'フォルダ内のファイル名取得
If Ubound(Flnmfp)=0 Then 'フォルダにファイルが無ければ終了
Exit Sub
End if

For i =1 to Ubound(Flnmfp)
Workbooks.open filename := Flnmfp(i)
Flnm=Dir(Flnmfp(i))
With Workbooks(Flnm).sheets("sheet1")
WS1.Cells(2, i).value=.Range("G5").value
WS1.Cells(3, i).value=.Range("G6").value
WS1.Cells(4, i).value=.Range("K7").value
WS1.Cells(5, i).value=CStr(.Range("G9").value) & CStr(.Range("N9").value) & CStr(.Range("P9").value)
'同じ要領で望みのセルを記入する
WS1.Cells(8, i).value=Flnm
End with
Workbooks(Flnm).close Savechanges:=False

Next i
End Sub

Sub fpFileName(ByVal myPath As String, ByRef Flnmfp() As String)
'サブフォルダも含め全部のxlsファイル名をフルパスで取得する
　　Dim cnt As Long, buf As String, f As Object

　　buf = Dir(myPath & "\*.xls")
　　Do While buf <> ""
　　　　cnt = Ubound(Flnmfp) + 1
ReDim Presearve Flnmfp(cnt)
　　　　Flnmfp(cnt)= myPath & "\" & buf
　　　　buf = Dir()
　　Loop
　　With CreateObject("Scripting.FileSystemObject")
　　　　For Each f In .GetFolder(myPath).SubFolders
　　　　　　Call fpFileName(f.Path, Flnmfp)
　　　　Next f
　　End With
End Sub

お礼

ありがとうございました。

お時間を割いていただきまして本当に感謝いたします。
実はまた問題が発生してしまっておりますが、補足に記入をさせていただきます。

まずはお礼まで。本当にありがとうございました。

回答No.3

High_Score

リンク更新をしないなら
変更前 Workbooks.open filename:=Flnmfp(i)
変更後 Workbooks.open filename:=Flnmfp(i), UpdateLinks:=0
メッセージが出る理由は、開こうとするファイルが他のどこかのファイルにリンクを張っていて、開く時にリンク先ファイルを参照しようとするからです。更新をせずに前回保存時の状態で開くなら、0です。

参考URL：

http://www.moug.net/tech/exvba/0060049.html

お礼

本当にありがとうございました。

やりたかったことが完全にできるようになりました。

もっともっと勉強していきたいと改めて思った次第でございます。

貴重なお時間をありがとうございました。

回答No.2

High_Score

No1です。訂正があります。
Flnm=Dir(Flnmfp(i))
を以下のように変更してください。
Dim Flnmsp As Variant '先頭のDimに追加してください
Flnmsp=split(Flnmfp(i), "\")
Flnm=Flnmsp(Ubound(Flnmsp))

変更しなくても動きますが、単にパス名を省いたファイル名を取得するのにフォルダを調べるDirを何度も使うのは無駄ですし、ファイル数によっては時間が掛かるからです。

お礼

この度は私の質問へのご回答をいただきましてありがとうございました。

たびたびで心苦しくもあるのですが、新たな注文を受けてしまい、必死に調べてみましたがこの記述方法への追加方法がわからないものが出てきてしまいました。

http://oshiete.goo.ne.jp/qa/8749164.html

に新たな質問として出させていただいております。たびたびですみませんがご教授いただけますでしょうか。

補足

ありがとうございました。

こちらの訂正もお時間を割いていただき、本当にありがたく存じます。

実はこの訂正を行うと集計がうまく行きませんでした。最初に回答いただいたVBAで作動いたしました。

ちょっとそれた内容になってしまうのですが、これを実行すると一回一回確認が出てきてしまいます。以下の内容です。
「このブックには、ほかのデータソースへのリンクが含まれています。

・リンクを更新すると、Excelは最新のデータを取り込もうとします。
・リンクを更新しないと、以前の情報が使用されます。

注意：データリンクは許可なく機密情報にアクセスして共有するのに使用される可能性があります。また、その他の問題を起こす可能性のある操作に使用される場合があります。このブックの作成元が信頼できない場合は、リンクを更新しないでください。」

と出てしまいます。これを出さなくする方法みたいなものはあるのでしょうか？？？
もしある場合、どのようにしたらよろしいでしょうか？

質問ばかりで申し訳ありませんが、あと一息というところで立ち往生してしまっております。