[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『フォルダー内にある全てのファイルを検索しコピー』（検索）
初めまして。 このような事は出来るのでしょうか。 宜しくお願いいたします。
エクセルファイル名は”全ビル集計表”です。 これを開きマクロを実行すると『どのブックを開きますか？』と メッセージが出て、指定のブックを選択 するとその中にある全てのファイルのシート名『工程内訳書』の 中のデータを全て”全ビル集計表”Sheet1に書き出す。
全てのファイルのシート名『工程内訳書』の範囲はA1:I52で出来ています。 ですので、”全ビル集計表”Sheet1の書き出す範囲は A1:I52 A53:I104 A104:I156 A157:I208 A209:I260 以下省略・・・ でコピーしたいです。
また、検索ファイルは全てにシートの保護も掛かっております。（パスワードは無し） 計算式も入っていますが”全ビル集計表”Sheet1には値のコピーを
このような操作ですが可能なのでしょうか。 よろしくお願いいたします。 ＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞
書き込みをして書き込みを削除した人がバージョン情報まで削除していたので復元しました。
※11さん、自分の発言はともかく、他人の書き込みを削除するのはやめましょう。 (カリーニン) 2016/08/27(土) 14:10
>>メッセージが出て、指定のブックを選択 >>するとその中にある全てのファイルのシート名『工程内訳書』
ん？
指定するのはブックですか？ であれば、【その中にあるすべてのファイル】とは？ フォルダを指定したいのではないんですか？
（β） 2016/08/27(土) 14:24
説明不足ですみません。もう一度書きます。 マクロを入れるエクセルファイルの名前は”全ビル集計表”です。 これを開きマクロを実行すると『どのフォルダーを開きますか？』と メッセージが出て、指定のフォルダーを選択 フォルダーの中には複数のファイルがあります。 するとその中にある全てのファイルのシート名『工程内訳書』の 中のデータを全て”全ビル集計表”Sheet1に書き出す。
（検索） 2016/08/27(土) 14:55
よろしくお願いいたします。 （検索） 2016/08/27(土) 14:58
直接の回答ではありません。
「フォルダ ブック シート 転記」で校内検索してみました。
http://www.excel.studio-kazu.jp/cgi-bin/estindex/estseek2.cgi?phrase=%E3%83%95%E3%82%A9%E3%83%AB%E3%83%80%E3%80%80%E3%83%96%E3%83%83%E3%82%AF%E3%80%80%E3%82%B7%E3%83%BC%E3%83%88%E3%80%80%E8%BB%A2%E8%A8%98&perpage=10&attr=&order=&clip=-1&navi=0
（カリーニン） 2016/08/27(土) 15:04
「フォルダ 選択」の検索例です。
http://www.excel.studio-kazu.jp/cgi-bin/estindex/estseek2.cgi?phrase=%E3%83%95%E3%82%A9%E3%83%AB%E3%83%80+%E9%81%B8%E6%8A%9E&perpage=10&attr=&order=&clip=-1&navi=0
（カリーニン） 2016/08/27(土) 15:06
（横丁） 2016/08/27(土) 19:33
カリーニンさん紹介のトピの回答コードを組み合わせれば、自助努力で解決だと思いますが これまた参考ということで一例をアップしておきます。（２つのプロシジャを、そのまま標準モジュールに貼り付けてください）
(横丁さんコメントの【簡単そうで不可能かと思いますよ】という意味がよくわかりませんが）
Sub Sample()
Dim shT As Worksheet
Dim shF As Worksheet
Dim bkF As Workbook
Dim fPath As String
Dim fName As String
Dim pos As Range
fPath = GetFolder("どのフォルダーを開きますか？")
If fPath = "" Then Exit Sub 'キャンセルボタン
Application.ScreenUpdating = False
Set shT = ThisWorkbook.Sheets("Sheet1")
shT.Cells.ClearContents
Set pos = shT.Range("A1")
fName = Dir(fPath & "\*.xls*")
Do While fName <> ""
If fName <> ThisWorkbook.Name Then
Set bkF = Workbooks.Open(fPath & "\" & fName)
Set shF = Nothing
On Error Resume Next
Set shF = bkF.Sheets("工程内訳書")
On Error GoTo 0
If Not shF Is Nothing Then
With shF.Range("A1:I52")
pos.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set pos = pos.Offset(.Rows.Count)
End With
End If
bkF.Close False
End If
fName = Dir()
Loop
End Sub
Private Function GetFolder(msg As String) As String
Dim Shell As Object, myPath As Object
Dim hWnd As Long
Dim stPath As Variant
Const BIF_RETURNNONLYFSDIRS = &H1 'ディレクトリのみ選択可
Const BIF_EDITBOX = &H10 'Edit_boxを表示
hWnd = Application.hWnd
Set Shell = CreateObject("Shell.Application")
Set myPath = Shell.BrowseForFolder(hWnd, msg, BIF_RETURNNONLYFSDIRS Or BIF_EDITBOX)
If Not myPath Is Nothing Then GetFolder = myPath.Items.Item.Path
Set Shell = Nothing
Set myPath = Nothing
End Function （β） 2016/08/27(土) 20:24
（β）さん ありがとうございます。 しかし何もコピーされず？またエラーも出ないのです。 もしかするとフォルダーの中に複数のフォルダーがありそこからもフォルダーになっている関連でしょうか。
名前は例ですので実際の名前と違いますが構層を書きます。
デスクトップ上に １番フォルダー ↓クリック ２番フォルダー （複数あり） ↓クリック ３番フォルダー ↓クリック ワークシート (.xlsx)←ここで工程内訳書のシートが出てきます。 これが原因でしょうか。
（日にち） 2016/08/27(土) 21:09
例が分かりずらいかと思い補足します。
フォルダー参照で選択した全ての中に含まれる(段階構層があっても) 工程内訳書のワークシートを見付け出しデータを全て”全ビル集計表”Sheet1に書き出す。 という事なのですが。 よろしくお願い致します。 （日にち） 2016/08/27(土) 21:38
指定フォルダの中のサブフォルダ階層すべてを対象にするということですね。 そういうことは、ちゃんと最初に説明してください。
コード書き次第アップします。 （それを待たずとも、カリーニンさん紹介のトピの回答コードで、要件にマッチしている部分を組み合わせればできるんですが 少しは参照してみましたか？）
（β） 2016/08/27(土) 21:50
＞このような事は出来るのでしょうか。
という割に反応が変ですね。
普通は、コードが提示されたら別の反応になるはずなんですけどねえ。
階層構造になっているという説明は最初からきちんとすべきですよ。
ところで、（日にち）さんて（検索）さんとどういう関係？
＞ 初めまして。
でもなんでもないじゃないですか。
最近、妙なハンドルネームの付け方が流行っているなと思っていました。
質問の要約を書くスタイルですね。
『Ａ４に年月を入力すると工期が出る』（工期）
が始まりですかね。
その後、
『他の入力文字から貼り付け』（貼り付け）
『セルの編集許可範囲』（範囲）
『エクセルファイルの容量』（file）
『一つのセルから結合したセルに貼り付ける』（結合）
『シート変更させない』（変更）
『 Sheet1が空白の場合空白』（空白）
『平成28年○月分を入力すると指定月の日にちを出す』（日にち）
と来たわけだけど、どうも同一人物のようですね。
同じHNを使ってくださいな。
そして、初めましてなどと虚偽の発言はされないほうがよい。
なお、すべて別人ですなどと主張されないほうがいいです。
というのは、管理者さんが調べればすぐわかることなので。
（γ） 2016/08/27(土) 21:54
すみません。 ニックネームは質問毎に変えないといけないかと思っておりました。 言い訳みたいですが。 以後は統一して質問させていただきます。 本当に申し訳ございません。 以後のニックネームは現在の"日にち"でお願いしたいと思います。
（日にち） 2016/08/27(土) 22:07
質問ごとにHN変えるのが最近流行なのかな？
[[20160821094620]] 『決まった曜日の数値を入力』（ちゃた）
（カエムワセト） 2016/08/27(土) 22:21
質問をたくさんして頂いても、別に問題はないです。
でも、
『エクセルファイルの容量』（file）
などで回答があったのですから、放置しないでいただきたい。
今回の質問と極めて共通する部分が大きいです。
放置しても、HNが違うから平気でいられるわけですよね。
今後、注意してくださいな。
（γ） 2016/08/27(土) 22:22
HNの件は、皆さんの指摘を真摯に受け止め、今後、注意願います。
コードすべて入れ替えてください。
Sub Sample2()
Dim shT As Worksheet
Dim shF As Worksheet
Dim bkF As Workbook
Dim fPath As String
Dim fName As Variant
Dim pos As Range
Dim fList As Variant
fPath = GetFolder("どのフォルダーを開きますか？")
If fPath = "" Then Exit Sub 'キャンセルボタン
Application.ScreenUpdating = False
Set shT = ThisWorkbook.Sheets("Sheet1")
shT.Cells.ClearContents
Set pos = shT.Range("A1")
fList = GetFiles(fPath)
For Each fName In fList
If fName <> ThisWorkbook.FullName Then
Set bkF = Workbooks.Open(fName)
Set shF = Nothing
On Error Resume Next
Set shF = bkF.Sheets("工程内訳書")
On Error GoTo 0
If Not shF Is Nothing Then
With shF.Range("A1:I52")
pos.Resize(.Rows.Count, .Columns.Count).Value = .Value
Set pos = pos.Offset(.Rows.Count)
End With
End If
bkF.Close False
End If
Next
End Sub
Private Function GetFolder(msg As String) As String
Dim Shell As Object, myPath As Object
Dim hWnd As Long
Dim stPath As Variant
Const BIF_RETURNNONLYFSDIRS = &H1 'ディレクトリのみ選択可
Const BIF_EDITBOX = &H10 'Edit_boxを表示
hWnd = Application.hWnd
Set Shell = CreateObject("Shell.Application")
Set myPath = Shell.BrowseForFolder(hWnd, msg, BIF_RETURNNONLYFSDIRS Or BIF_EDITBOX)
If Not myPath Is Nothing Then GetFolder = myPath.Items.Item.Path
Set Shell = Nothing
Set myPath = Nothing
End Function
Private Function GetFiles(fPath) As Variant
Dim objWshShell As Object
Dim strTargetPath As String '対象フォルダパス
Dim strRedirectPath As String '一時ファイルパス
Dim rtn As Long
Dim varFileList As Variant
Dim myTime As Double
Dim fNo As Integer
Dim buf() As Byte
strTargetPath = fPath & "\"
strRedirectPath = Environ$("Temp") & "\Dir.tmp"
Set objWshShell = CreateObject("Wscript.Shell")
rtn = objWshShell.Run("CMD /C DIR """ & strTargetPath & "*.xls*" _
& """ /A-D /B /S > """ & strRedirectPath & """", 7, True)
Set objWshShell = Nothing
fNo = FreeFile()
Open strRedirectPath For Binary As fNo
ReDim buf(1 To LOF(fNo))
Get #fNo, , buf
Close #fNo
varFileList = Split(StrConv(buf, vbUnicode), vbCrLf)
Kill strRedirectPath
ReDim Preserve varFileList(LBound(varFileList) To UBound(varFileList) - 1)
GetFiles = varFileList
End Function
（β） 2016/08/27(土) 22:26
HNnoの件は謙虚に受け止めます。申し訳ございません。
実際に試してエラーはでませんが工程内訳書のA1:I52の範囲が 全ビル集計表”Sheet1の以下の範囲に コピーされないのと途中文字等の抜けも出てしまいます。
工程内訳書のワークシート (.xlsx）が５個あった場合 全ビル集計表”Sheet1に書き出す範囲の例です。 ↓ A1:I52 ←１個目の工程内訳書のA1:I52をここへ A53:I104 ←２個目の工程内訳書のA1:I52をここへ A104:I156 ←３個目の工程内訳書のA1:I52をここへ A157:I208 ←４個目の工程内訳書のA1:I52をここへ A209:I260 ←５個目の工程内訳書のA1:I52をここへ
また、実行してみて分かったのですが工程内訳書のシート内に他の このブックには他のデータソースへのリンクが含まれています。 と表示され更新か更新しないかが出ますが更新を押しました。 テストは工程内訳書のワークシート (.xlsx）５個が入っていたため 5回更新を押して行いました。 何度も申し訳ございませんがよろしくお願い致します。
（日にち） 2016/08/27(土) 23:14
転記される、されないという件については、こちらでは問題なく、要求された場所に転記されています。
>するとその中にある全てのファイルのシート名『工程内訳書』の
こういうことですから、なんというブック名かはわかりませんけど、とにかくフォルダ内のエクセルブックの "工程内訳書" という名前のシートを対象にしています。 フォルダ内のエクセルブックであっても "工程内訳書" という名前のシートがなければ、それは転記対象にはなりません。
確かに "工程内訳書" という名前のシートがあるのに、転記されないということですか？
>途中文字等の抜けも出てしまいます。
まったく理由がわかりません。コードでは、指定された領域に指定されたサイズの転記を行っています。 文字の抜け というのは、具体的にはどんな状態なんですか？
次に、データソースへのリンクの件、これはマクロとは関係のない話です。 たとえば、どのブックでもいいですが手動で開いてみてください。 メッセージがでるのでしょうね。外部リンク式がかかれているのではないですか？
もし、外部リンク式があるけれど、メッセージを出さないで処理したいということなら、そういうことを ちゃんと説明してください。
（β） 2016/08/27(土) 23:52
ありがとうございます。 確かに "工程内訳書" という名前のシートがあるのに、転記されないということですか？ はい。5個テスト用で工程内訳書を作り実行しました。 結果はA1:I52までの範囲は5個の内1個の中のデータを確実に転記出来ていますが 他はほとんどが転記されていませんという結果です。 しかし、（β)さんのテストでは問題なく要求された場所に転記が出来ているとなれば 私の 工程内訳書の中のデータに問題があるのかもしれません。 気になる事は、数箇所セルの結合で入力されている部分がある事くらいで・・・ 全ビル集計表”Sheet1も工程内訳書の同じセルの結合にしています。 明日また実行テストをしてみます。
リンクの件ですが外部リンクがあるみたいですのでメッセージを出さずに処理したいです。 （日にち） 2016/08/28(日) 00:30
まず、（横丁） 2016/08/27(土) 19:33 でコメントがあったような手作業による確認もしてください。
A.xlsx 、B.xlsx、C.xlsx、D.xlsx、E.xlsx があったとします。
A.xlsxを開きます。リンク云々がでるのでしょうから、更新します。で、工程内訳書シートのA1:I52を選択して Ctrl/c。 全ビル集計表.xlsmのSheet1のA1を選択して形式を選択して値貼り付け。
B.xlsxについても、同様で A53 に値貼り付け、C.xlsxについても・・・・
という操作を、テスト的に作成した５つのブックに対して実行して、その結果がどうなるかを確認して下さい。
（β） 2016/08/28(日) 08:37
（γ） 2016/08/28(日) 09:40
申し訳ございません。 私のミスでした。全ビル集計表のSheet1で結合セルがおかしい部分があり 修正しましたら完璧にできました。 また、手作業による確認もしては問題はありませんでした。 その他のテストで５個のbookを作成（範囲内に番号１〜468 469〜936 937〜1404 1405〜1872 1873〜2340） のセル全てに番号を入力し、全ビル集計表のSheet1でマクロを実行。 結果１〜2340全ての書き込み大丈夫でした。
後は、外部リンクの更新画面が毎回表示があり更新でマクロを実行しており ますが、外部リンク式があるけれど、メッセージを出さないで処理したいのですが。 よろしくお願い致します。 （日にち） 2016/08/28(日) 10:01
Set bkF = Workbooks.Open(fName)
これを
・もし、最新の状態で（更新をして）取り込みたいなら
Set bkF = Workbooks.Open(fName,True)
・もし、更新せず、現時点のエクセルブックの値を取り込みたいなら
Set bkF = Workbooks.Open(fName,False)
これで試してください。
（β） 2016/08/28(日) 10:13
（β）さん早速ありがとうございます。 ・もし、最新の状態で（更新をして）取り込みたいなら Set bkF = Workbooks.Open(fName,True) 今回はこちらを変更し更新画面が出ずに出来ました。
一つお聞きしたいのですが、全ビル集計表”Sheet1に転記される 順番には決まりがあるのでしょうか。
（日にち） 2016/08/28(日) 15:42
フォルダにせよファイルにせよ、名前順になっているかと思います。 これを、特定の順番で処理したい場合は、取り込み対象のブックフルパス（Sample2 では fList という名前の配列に入っています）を 取り込み前に、必要な順番になるように並び替えを行うということになりますね。
（β） 2016/08/28(日) 16:50
ありがとうございます。 名前の順番ですね。分かりました。
特定の順番で処理の場合この辺を変えると変更できるという事ですね。 Dim fList As Variant
fList = GetFiles(fPath)
For Each fName In fList
もし変更の場合質問させていただきますので
その時はよろしくお願い致します。
お世話になりました。
（日にち） 2016/08/28(日) 17:30
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.