ファイル選択マクロで教えて下さい

質問

別々のフォルダ内にあるファイルを一括して読み込むマクロを教えて下さい。

まず
\\10.000.000.000\data\検査結果\LETO\712\20150204160549\ID000
というフォルダ内に
090
100
110
・
・
・
・
270

というフォルダが13個あります。この13個のフォルダ内には
RawData　という名前のファイルがそれぞれ保存されています。

現在はこのRawDataファイルを1回1回選択してエクセルシートに読み込んでいます。

これを上記アドレスの最後の、ID000のフォルダを選択してOKを押すと
13個のフォルダ内のRawDataというファイル名の中身を各シートの指定のセルに
貼り付けるようにしたいです。

090フォルダ内のRawDataはブック1のシート1のセルF2へ
100フォルダ内のRawDataはブック1のシート2のセルF2へ

という感じで、シートは変わりますが、セル番号はかわりません。

現在使用しているマクロを貼り付けておいきます。
ご指導の程宜しくお願いします。

Sub open2(pbs_pos)

   f_name_org = ActiveWorkbook.Name

   MsgBox ("PBS = " & pbs_pos & " degのraw_dataファイルを選択")
   open_file

   fname_temp = ActiveWorkbook.Name
   Range("b1:b180").Copy

   Workbooks(f_name_org).Activate
   Sheets("pbs" & pbs_pos).Activate
   Range("f2").Select
   ActiveSheet.Paste
   Application.CutCopyMode = False
   Workbooks(fname_temp).Close

Sheets("calibration").Select

End Sub

回答No.5

kagakusuki · ベストアンサー

回答No.4の続きです。

Private Sub QNo9104083_ファイル選択マクロで教えて下さい_コア部分(ByVal ParentPath _
As String, ByVal OriginPath As String, ByRef NoSheetFile As String, ByRef n As Integer)

Const CopyFileName = "RawData" 'データのコピー元とするファイルのファイル名
Const CopyCells = "B1:B180" 'データのコピー元とするセル範囲
Const PasteCell = "F2" 'データの貼付先のセル範囲の内、左上の隅のセルのアドレス
Const InitialWord = "pbs" '貼付先のシート名の先頭に付く文字列
Const FormatSheetName = "雛型" '貼付先のシートを新規作成する際の雛型となるシートのシート名
Dim f As Variant, i As Long, j As Long, buf As Variant, buf2 As Variant, _
myObject As Object, PasteSheetName As String, FirstCopyColumn As Long, _
CopyColumns As Long, FirstCopyRow As Long, LastCopyRow As Long, _
myCalculation As Integer, myBoolean As Boolean

With Range(CopyCells)
FirstCopyColumn = .Column
CopyColumns = .Columns.Count
FirstCopyRow = .Row
LastCopyRow = FirstCopyRow + .Rows.Count - 1
End With

Set myObject = CreateObject("Scripting.FileSystemObject")
For Each f In myObject.GetFolder(ParentPath).SubFolders
Call QNo9104083_ファイル選択マクロで教えて下さい_コア部分( _
f.Path, OriginPath, NoSheetFile, n)

If Dir(f.Path & "\" & CopyFileName) <> "" Then
PasteSheetName = f.Path
i = 0
For i = 1 To 9
PasteSheetName = Replace(PasteSheetName, i, 0)
Next i
If InStr(InStrRev(f.Path, "\"), PasteSheetName, 0) > 0 Then
PasteSheetName = Mid(f.Path, InStr(InStrRev(f.Path, "\"), PasteSheetName, 0))
If Replace(PasteSheetName, 0, "") <> "" Then
Do While Left(PasteSheetName & "1", 1) = "0"
PasteSheetName = Mid(PasteSheetName, 2)
Loop
End If
PasteSheetName = InitialWord & PasteSheetName
Else
PasteSheetName = Mid(f.Path, InStrRev(f.Path, "\") + 1)
End If
PasteSheetName = Replace(Mid(Left(f.Path, InStrRev(f.Path, "\")) _
, Len(OriginPath) + 2) & PasteSheetName, "\", "-")

myBoolean = Not IsError(Evaluate("ROW('" & PasteSheetName & "'!A1)"))
If Not myBoolean Then
If IsError(Evaluate("ROW('" & FormatSheetName & "'!A1)")) Then
NoSheetFile = NoSheetFile & vbCrLf & Mid(f.Path, Len(OriginPath) + 1)
Else
Sheets(FormatSheetName).Copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = PasteSheetName
myBoolean = True
End If
End If

If myBoolean Then
Open f.Path & "\" & CopyFileName For Input As #1
Sheets(PasteSheetName).Range(PasteCell).Resize( _
LastCopyRow - FirstCopyRow + 1, CopyColumns).ClearContents
If Not EOF(1) Then
For i = 1 To LastCopyRow
Line Input #1, buf
If i >= FirstCopyRow And buf <> "" Then
buf = Replace(Replace(",," & buf & String(CopyColumns, ","), ",", "", _
, FirstCopyColumn), ",", vbVerticalTab, , CopyColumns + 1)
buf = Mid(Left(buf, InStrRev(buf, vbVerticalTab) - 1), _
InStr(buf, vbVerticalTab) + 1)
Sheets(PasteSheetName).Range(PasteCell).Resize(1, CopyColumns) _
.Offset(i - FirstCopyRow).Value = Split(buf, vbVerticalTab)
End If
If EOF(1) Then Exit For
Next i
End If
Close #1
n = n + 1
End If
End If
Next f

If NoSheetFile <> "" Then
buf = "指定されたフォルダー内の下記のサブフォルダーにもデータの" _
& "コピー元のファイルとして指定されている" _
& vbCrLf & vbCrLf & CopyFileName & vbCrLf & vbCrLf _
& "というファイル名のファイルが存在していますが、" _
& "コピーしたデータの貼付先となるシートが見つからなかった事と、" _
& "貼付先のシートを新規に作成する際の雛型となる" _
& vbCrLf & vbCrLf & FormatSheetName & vbCrLf & vbCrLf _
& "というシート名のシートも見つからなかったため、" _
& "データを転記する事が出来ませんでした。" & vbCrLf & vbCrLf & vbCrLf
NoSheetFile = buf & Replace(NoSheetFile, buf, "")
End If

End Sub

　以上です。

お礼

全て完璧。パーフェクトでした！
毎回本当に素晴らしいご回答をありがとうございます。
またよろしくお願いします。

回答No.4

kagakusuki

>ファイル種類の件ですが、拡張子はございません。

という事ですと、おそらくそれはOSがWindowsではないコンピュータで作成されたファイルではないかと思います。
　一応、通常のWindowsのtxtファイルから拡張子を外したファイルを処理対象にした、質問者様が仰る様な処理を行うVBAのマクロを作る事は出来たのですが、私が使用しているパソコンはOSがWindowsのものだけですし、質問者様が仰っておられるRawDataファイルがどの様なソフトによって作成されたものなのか不明ですので、私が作成した拡張子無しのファイルに対して無事に処理を行う事が出来たからと言って、質問者様が仰っておられるRawDataファイルに対しても同様に処理を行う事が出来るものなのかどうかは自信が御座いません。
　ですから、念のためにまず仮のExcelbookとID000フォルダーをコピーしたフォルダーを作成しておいて、上手く動作するかどうかを御確認願います。

　使い方ですが、

Sub QNo9104083_ファイル選択マクロで教えて下さい_マクロ起動部分()

と

Private Sub QNo9104083_ファイル選択マクロで教えて下さい_コア部分(ByVal ParentPath As String, ByVal OriginPath As String, ByRef NoSheetFile As String, ByRef n As Integer)

の2つに分かれておりますので、まず「～マクロ起動部分」の方の中にある

Const DefaultPath _
= "○○○"

の所の「○○○」の代わりに、RawDataというファイルが存在するID090～ID270の各フォルダーを全て含んでいるフォルダーであるID000というフォルダーのパス(御質問文の通りであれば　\\10.000.000.000\data\検査結果\LETO\712\20150204160549\ID000)を入力して下さい。
　その上で、「～マクロ起動部分」の方を起動させて下さい。
　すると親フォルダーを選択するためのダイアログボックスが現れて、定数DefaultPath内に格納されているパスのフォルダーの所が開きますので、もし別のフォルダー内に存在するサブフォルダー内のRawDataファイルに対して処理を行う場合には、そのダイアログボックスを使って、別のフォルダーを指定して下さい。
　すると、「～マクロ起動部分」のマクロが自動的に「～コア部分」のマクロを呼び出し、「～コア部分」のマクロはID000というフォルダーの中に存在するサブフォルダーの全てを対象にして、RawDataという名称の拡張子無しのファイルの有無を調べて、もし該当するファイルが存在している場合には、そのB1:B180に相当する箇所のデータを取り出して、各サブフォルダーの名称に対応するシート名を持つシートのF2セルに値を転記します。
　各サブフォルダーの名称とそれに対応するシート名の関係は、サブフォルダーのフォルダー名の中に0～9の数字が含まれている場合は、フォルダー名の中で一番最初に数字が表れた位置以降の部分の文字列のみを取り出して、もしその文字列の先頭部分に0が並んでいた場合には、その先頭部分の0を文字列から削除した上で、頭に"pbs"の3文字を付けたものが、対応するシート名となります。(フォルダー名の中に数字が含まれていない場合には、単純にフォルダー名の頭に"pbs"の3文字を付けた名称のシートにデータが転記されます)
　ですから、例えばID009900Aという名称のサブフォルダーと、XYZ0000900Aというという名称のサブフォルダーがあり、そのどちらにもRawDataという名称の拡張子無しのファイルが存在した場合には、どちらのデータもpbs9900Aシートに転記される事になりますので、ID009900Aフォルダー内のファイルのデータが転記された後で、XYZ0000900Aフォルダー内のファイルのデータが上書きされる事によって、ID009900Aフォルダー内のファイルのデータから転記されたデータが消えてしまう事になりますので、フォルダー名には注意して下さい。
　尚、もしID000の中にあるID090～ID270等のサブフォルダーの中に、更に下位のフォルダーがあり、その中にもRawDataという名称の拡張子無しのファイルが存在した場合にも、そのデータが転記される様になっております。
　その場合、データの転記先のシートのシート名は
「サブフォルダー名」&「－」&「pbs」&「『RawDataファイルが存在するフォルダーの名称』の中で最初に1～9の数字が現れた位置以降の部分」
という形式となります。
　ですから例えばID090の中にID0901というフォルダーがあり、そのまた中にID09012というフォルダーがあり、そのID09012フォルダーの中にRawDataファイルが存在している場合には、そのデータの転記先のシートのシート名は
ID090-ID0901-pbs09012
になります。
　そしてもし転記先のシートが存在していない場合でも、データの転記先のシートのレイアウトのフォーマットが設定済みとなっている雛型用のシートととして、

雛型

というシート名のシートがbook内に用意されていれば、その雛型のシートを自動的にコピーし、そのコピーシートの名称を適切なものに変更してから、データの転記先のシートとして使用する様になっています。
　尚、もし該当するシート名のシートも無ければ、雛型シートも存在しないという様な場合には、データを転記する事が出来ませんので、転記が可能なデータのみを転記した上で、処理が終了してから最後に「データが転記出来なかったサブフォルダー」(RawDataファイルが含まれていないものは除く)の名称がMsgboxで表示される様になっています。

Sub QNo9104083_ファイル選択マクロで教えて下さい_マクロ起動部分()

Const DefaultPath _
= "\\10.000.000.000\data\検査結果\LETO\712\20150204160549\ID000" 'フォルダー選択画面を開く際に開くフォルダーのパス
Dim ParentFolder As Object, myBox As Variant, OriginPath As String, _
NoSheetFile As String, n As Integer

With Application
myCalculation = .Calculation
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

label1:
Set ParentFolder = CreateObject("Shell.Application"). _
BrowseForFolder(0, "親フォルダーを選択して下さい", _
785, DefaultPath)
If ParentFolder Is Nothing Then
myBox = MsgBox("親フォルダーが選択されていません。" _
& vbCrLf & "親フォルダーの選択をやり直しますか?" & vbCrLf & vbCrLf _
& "[はい]:フォルダーの選択をやり直します" & vbCrLf _
& "[いいえ]:処理を中止してマクロを終了します", _
vbYesNo + vbExclamation, "フォルダー未選択")
If myBox = vbNo Then
MsgBox "マクロを終了します", vbInformation, "マクロの終了"
Exit Sub
Else
GoTo label1
End If
Else
OriginPath = ParentFolder.Items.Item.Path
Call QNo9104083_ファイル選択マクロで教えて下さい_コア部分( _
OriginPath, OriginPath, NoSheetFile, n)
End If
Set ParentFolder = Nothing

Calculate
With Application
.Calculation = myCalculation
.ScreenUpdating = True
End With

If n = 0 Then
If NoSheetFile = "" Then
MsgBox "データを転記しなければならないファイルが見つかりませんでした" _
, vbInformation, "該当ファイル無し"
Else
MsgBox "データの転記先となるシートが存在しないため、データを転記する" _
& "事が出来ませんでした", vbExclamation, "データ転記不能"
End If
Else
MsgBox n & "個のファイルのデータを転記しました", vbInformation, "データ転記終了"
End If
If NoSheetFile <> "" Then _
MsgBox NoSheetFile, vbExclamation, "転記出来なかったデータ"

End Sub

※まだ途中なのですが、このサイトの回答欄には4000文字までしか入力出来ませんので、残りは又後で投稿致します。

回答No.3

kagakusuki

追加情報有難うございます。
　しかしながら、まだ不明な点がいくつか御座います。

　特に良く解らないのが、

>RawDataといファイルには拡張子はありません。

という点です。

>メモなどで開くと
>0,5
>2,25
>4,20
>・
>・
>・
>というようになっています。
>つまり現在は、Ｅ16のマクロを実行して、PBS090というフォルダ内のRawDataを選択するとシート【pbs90】のＥ2～Ｆ181に上記の数値のカンマで区切った数値が入力されるようになっています。

という事から考えますと、CSVファイルのようにも思えるのですが、本当に拡張子が付いていないのでしょうか？　拡張子が　.csv　か　.txt　になっているという事は無いのでしょうか？
　試しに、そのファイルのアイコンを右クリックし、現れた選択肢の中にある[プロパティ]という項目をクリックした際に現れる「RawDataのプロパティ」ダイアログボックスの[全般]タブを開いてみて下さい。
　「ファイルの種類」欄に

Microsoft Excel CSV ファイル (.csv)

などといった具合に、(　)内に拡張子が表示されてはいないかどうかを御確認の上、拡張子の有無と、もし拡張子があった場合には、どの様な拡張子なのかを御教え願います。

　それから、

>ブック1の中には
>シート【calibration】
>シート【pbs90】シート【pbs100】シート【pbs110】シート【pbs120】シート【pbs130】
>シート【pbs150】シート【pbs180】シート【pbs210】シート【pbs230】シート【pbs240】
>シート【pbs250】シート【pbs260】
>というシートがあります

との事ですが、例えば【pbs90】シートの場合、そのシート名は

pbs90

の様な【　】が付かないシート名でもなければ

【PBS90】

の様な大文字や

【ｐｂｓ９０】

の様な全角文字でもなく、【　】付きの半角小文字のシート名になっているという考えで宜しいでしょうか？

　後、PBS090というフォルダー名と【pbs90】というシート名の様に、フォルダー名に対応するシート名がある場合は良いのですが、もし対応するシート名が無かった場合にはどのようにすればよろしいのでしょうか？
　単にそのフォルダー内のRawDataファイルのデータは貼り付けずに済ますだけで宜しいのでしょう？
　それとも、何か雛型となるシートのコピーシートを作成して、そのコピーシートのシート名をフォルダー名に対応するシート名に変更した上で、そのフォルダー内のRawDataファイルのデータを貼り付ける様にしなければならないのでしょうか？

　又、逆にシートだけは存在していても、そのシート名に対応するフォルダーが存在していなかった場合にはどのようにすればよろしいのでしょうか？
　そのシートのF2:F181のセル範囲に存在するデータを消去すれば宜しいのでしょうか？
　それとも、そのシートに対しては何もせずに、古いデータのままで残す様にした方が良いのでしょうか？

　それから、

>シート【pbs90】のＥ2～Ｆ181に上記の数値のカンマで区切った数値が入力されるようになっています。

との事ですが、コピーするのはRange("b1:b180")で、貼り付けるのはRange("f2")ですので、Ｅ2～Ｆ181というのは入力ミスか何かの間違いで、正しくはF2～F181ではないかと思うのですが、それで間違いは御座いませんでしょうか？

補足

ファイル種類の件ですが、拡張子はございません。
プロパティ確認すると【ファイル】となっています。
またこのファイルを開こうとすると
ファイルを開くプログラムの選択画面が表示されます。

次にシート名の件ですが
こちらはご指摘の通り、pbs90
というシート名です。【】は分かりやすくする為に付けておりました。
すみません。

次にフォルダに対応するシート名が無かった場合ですが
対応するシート名がないことはございませんので大丈夫です。
逆の場合もございませんので大丈夫です。

最後に
＞との事ですが、コピーするのはRange("b1:b180")で、貼り付けるのはRange("f2")ですので
Ｅ2～Ｆ181というのは入力ミスか何かの間違いで、正しくはF2～F181ではないかと思うのですが
それで間違いは御座いませんでしょうか？

はい。申し訳ございません。
私が間違えておりました。
kagakusuki さんのおっしゃられている事で間違いありません。

お手数をお掛けして申し訳ございません。
宜しくお願いします。

回答No.2

kagakusuki

質問者様が説明しておられない不明な点が幾つかあるため、このままでは、質問者様がどの様に自動化させたいと考えておられるのかが解りませんので、下記の点に関して御説明願います。

>13個のフォルダ内のRawDataというファイル名の中身を各シートの指定のセルに貼り付けるようにしたいです。

との事ですが、その貼り付けたいデータとは、各「RawDataというファイル」の中の何というシート名のシート上のB1:B180のセル範囲の事なのかに関して何も説明が無いため、どのB1:B180のセル範囲をコピーすれば良いのか判断が付きません。
　ですから、どのシートからコピーしてくれば良いのかを御教え願います。(もしかしますと、「RawData」と言うファイル名の各ファイルは、何れもシートが1枚しか存在していないという事なのでしょうか？)

　それと、貼り付け先のシートのシート名も、どの様なパターンで決まるのかが不明なため、このままではどのシートに貼り付ければ良いのか判りません。
　御質問文にある質問者様のマクロでは、

Sheets("pbs" & pbs_pos).Activate

となっておりますが、質問者様のマクロは

>RawDataファイルを1回1回選択してエクセルシートに読み込んで

というものなのですから、変数 pbs_pos の値も、そのマクロを1回起動させるごとに1つの値しか採りませんから、下位フォルダーが複数存在しているのに対して、貼り付け先のシート名が1つしかない事になり、それでは複数のフォルダーに対して連続して自動的に処理を行う事が出来ません。
　ですから、「ID000内に存在する13個のフォルダーのフォルダー名を基にして、どの様なルールで変数 pbs_pos の値が決まるのか」という事を御説明願います。(もしかしますと、例えば090フォルダ内のRawDataファイルのB1:B180のセル範囲のデータの貼り付け先のシートは、ActiveWorkbookの「pbs090」シートになる、といったパターンになっていると考えても宜しいのでしょうか？)

　後、質問者様のマクロでは1行目が

Sub open2(pbs_pos)

となっておりますが、それでは「他のマクロでSub open2(pbs_pos)のマクロを呼び出した際に、Sub open2(pbs_pos)内でpbs_posの値が決まり、そのpbs_posの値を他のマクロに渡す」というマクロになってしまうだけであり、「他のマクロ内でpbs_posの値が指定すると、そのpbs_posの値を使ってSub open2(pbs_pos)内での処理を行う」という使い方が出来ませんが、それで本当に宜しいのでしょうか？
　もしかしますと、

Sub open2(pbs_pos)

というのは

Sub open2(ByVal pbs_pos As Variant)

の間違いではないでしょうか？

補足

申し訳ございません。会社のマクロだった為
私の方で色々と省略したことにより混乱や伝わらない部分が多く出てしまいました。

長くなりますが、再度細かく説明させて頂きます。

まずブック1というエクセルファイルがあります。
ブック1の中には
シート【calibration】
シート【pbs90】シート【pbs100】シート【pbs110】シート【pbs120】シート【pbs130】
シート【pbs150】シート【pbs180】シート【pbs210】シート【pbs230】シート【pbs240】
シート【pbs250】シート【pbs260】
というシートがあります
その中のシート【calibration】にマクロ実行ボタンがあります。
実行ボタンはＥ１６セル～Ｑ16セルまで1個ずつ設置されています。

今回はＥ16セルにあるマクロボタンを押したとしてお話しを進めさせて頂きます。
Ｅ16セルにあるマクロボタンを押すとシート【pbs90】のセルＥ2～Ｆ181のセルに
選択したRawDataの数値を貼り付けるマクロに現在はなっています。
またこのRawDataといファイルには拡張子はありません。
既存のマクロでどのように読み取っているかは私にはわかりませんが
メモなどで開くと
0,5
2,25
4,20
・
・
・
というようになっています。
つまり現在は、Ｅ16のマクロを実行して、PBS090というフォルダ内のRawDataを選択すると
シート【pbs90】のＥ2～Ｆ181に上記の数値のカンマで区切った数値が入力されるように
なっています。

Ｆ16のマクロを実行するとシート【pbs100】に上記に書いたことが実行されるようになっています。

順番は上記のシート名を書いたところと同じです。
マクロ実行がＧ16ならシート【pbs110】
Ｈ16ならシート【pbs120】
・
・
・
といった感じです。

これを1回１回行わなくてもシート【pbs90】～シート【pbs260】の
Ｅ2～Ｆ181セルにRawDataの数値を貼り付けできるようにしたいです。

フォルダは前にも書きましたが
\\10.000.000.000\data\検査結果\LETO\712\20150204160549\ID000
というフォルダ内に
PBS090
PBS100
PBS110
・
・
・
・
PBS270
というフォルダがあります。（前回の質問ではPBSが抜けていました）
このそれぞれのPBSフォルダの中にRawDataがあります。

ひとまずはここで一度再度のご説明を終えます。
質問の答えにはなっていないと思いますが
これを読んで頂き、再度ご質問をして頂ければと思います。
非常にわかりずらい説明で申し訳ありませんが
宜しくお願いします。

回答No.1

Prome_Lin

ご質問内容に、合致しているか少々不安ですが、以下の「VBA」ではどうでしょうか？

前提条件としては、「Sheet1」のみが存在し、その「Sheet1 」には何もデータが入っていないまっさらの状態のエクセルファイルを「\\10.000.000.000\data\検査結果\LETO\712\20150204160549\ID000」フォルダに適当な名前を付けて（～.xlsm）保存し、以下の「VBA」をコピー＆ペースとします。

あとは、「F5」で実行すると、「VBA」をコピー＆＠ペーストしたエクセルファイルに「090」～「210」までのシートが作成されています。

もちろん、「090」の「RawData.xlsx」の「Sheet1」の内容が、「090」と名付けられたシートにコピーされています。

具体的にプログラムの説明をさせて頂くと、「p = ActiveWorkbook.Path」で、このプログラムファイルが存在する位置を取得しています。

「For i = 90 to 210 Step 10」としてしまうと、シートの順番が最終的に「210→200→190・・・090」となってしまうので、「210」から行っています。

「d = Right("0" & CStr(i), 3)」で、「090」のように頭が「０」の場合の文字列を作成しています。

それぞれのフォルダ（「090」など）にある「RawData.xlsx」ファイルを開き、オブジェクト変数「z」に格納しています。

「z」の「Sheet1」シートの内容を、プログラムが存在しているエクセルファイルにペーストします。

そのシートの名前を「090」など、フォルダ名に変更します。

「RawData.xlsx」を閉じます。

と、これを繰り返し、最後、プログラムが存在するエクセルの何もデータが入っていない最初から存在していたシートを削除しておきました。

Sub Test_07()
Dim i As Integer
Dim d, p As String
Dim z As Object
p = ActiveWorkbook.Path
For i = 210 To 90 Step -10
d = Right("0" & CStr(i), 3)
Set z = Workbooks.Open(p & "\" & d & "\RawData.xlsx")
z.Worksheets("Sheet1").Copy After:=ThisWorkbook.Worksheets("Sheet1")
ActiveSheet.Name = d
z.Close
Next i
ThisWorkbook.Worksheets("Sheet1").Delete
End Sub