vba dirにおけるフォルダ内にあるフォルダからのファイル取得

vba初心者です。現在同じフォルダ内に同じ形式で従業員の評価点が記載されている複数のシートの情報を抽出して別ブックに転記するプログラムを書いております。ユーザーに参照フォルダと出力先のブックを選択させる方式で、完成したのですがバグがあり完全できません。具体的には
１、参照フォルダにサブフォルダが存在する場合、サブフォルダ内のファイルから情報を抽出できない
２、出力先ブックにマクロ実行しているブックを選択するとファイルを二重に開こうとして止まってしまう

の二点です。

どう書き直せばいいかご教授お願い致します。

以下作成したプログラム





Option Explicit
Dim fpath1 As Variant
Dim fpath2 As Variant
Dim openfilename1 As Variant
Dim openfilename2 As Variant
Dim folder As Object
Dim file As Object



Private Sub CommandButton1_Click()
Set folder = CreateObject("Shell.Application"). _
BrowseForFolder(0, "フォルダを選択してください", 0, "C:￥")

If Not folder Is Nothing Then
参照.Value = folder.self.Path
End If

End Sub

Private Sub CommandButton2_Click()
Dim filename As String

fpath2 = Application.GetOpenFilename(filefilter:="Excelファイル,*.xlsx;*.xlsm;*.xls")
openfilename2 = Dir(fpath2)
出力.Text = fpath2


End Sub

Private Sub CommandButton3_Click()
Const cnsDIR = "\*.xlsx"
Dim strPath As String
Dim strFilename As String
Dim GYO As Long
Dim i As Long

'フォルダの場所指定
strPath = 参照.Value

'先頭のファイル名取得
strFilename = Dir(strPath & cnsDIR, vbNormal)

i = 1

'ファイルが見つからなくなるまで繰り返す
Do While strFilename <> ""

'行を加算
i = i + 1

Workbooks.Open "C:\Users\kairi\Downloads\評価\" & strFilename
ActiveWorkbook.ActiveSheet.Range("J2").Copy
ActiveWorkbook.Close

Workbooks.Open (fpath2)
ActiveWorkbook.ActiveSheet.Cells(i, 1).PasteSpecial
ActiveWorkbook.Close SaveChanges:=True


Workbooks.Open "C:\Users\kairi\Downloads\評価\" & strFilename
ActiveWorkbook.ActiveSheet.Range("D1").Copy
ActiveWorkbook.Close

Workbooks.Open (fpath2)
ActiveWorkbook.ActiveSheet.Cells(i, 2).PasteSpecial
ActiveWorkbook.Close SaveChanges:=True


Workbooks.Open "C:\Users\kairi\Downloads\評価\" & strFilename
ActiveWorkbook.ActiveSheet.Range("K1").Copy
ActiveWorkbook.Close

Workbooks.Open (fpath2)
ActiveWorkbook.ActiveSheet.Cells(i, 3).PasteSpecial
ActiveWorkbook.Close SaveChanges:=True


Workbooks.Open "C:\Users\kairi\Downloads\評価\" & strFilename
ActiveWorkbook.ActiveSheet.Range("M1").Copy
ActiveWorkbook.Close

Workbooks.Open (fpath2)
ActiveWorkbook.ActiveSheet.Cells(i, 4).PasteSpecial
ActiveWorkbook.Close SaveChanges:=True


Workbooks.Open "C:\Users\kairi\Downloads\評価\" & strFilename
ActiveWorkbook.ActiveSheet.Range("O1").Copy
ActiveWorkbook.Close

Workbooks.Open (fpath2)
ActiveWorkbook.ActiveSheet.Cells(i, 5).PasteSpecial
ActiveWorkbook.Close SaveChanges:=True


Workbooks.Open "C:\Users\kairi\Downloads\評価\" & strFilename
ActiveWorkbook.ActiveSheet.Range("L5").Copy
ActiveWorkbook.Close

Workbooks.Open (fpath2)
ActiveWorkbook.ActiveSheet.Cells(i, 6).PasteSpecial
ActiveWorkbook.Close SaveChanges:=True


Workbooks.Open "C:\Users\kairi\Downloads\評価\" & strFilename
ActiveWorkbook.ActiveSheet.Range("L6").Copy
ActiveWorkbook.Close

Workbooks.Open (fpath2)
ActiveWorkbook.ActiveSheet.Cells(i, 7).PasteSpecial
ActiveWorkbook.Close SaveChanges:=True


Workbooks.Open "C:\Users\kairi\Downloads\評価\" & strFilename
ActiveWorkbook.ActiveSheet.Range("L7").Copy
ActiveWorkbook.Close SaveChanges:=True

Workbooks.Open (fpath2)
ActiveWorkbook.ActiveSheet.Cells(i, 8).PasteSpecial
ActiveWorkbook.Close SaveChanges:=True


Workbooks.Open "C:\Users\kairi\Downloads\評価\" & strFilename
ActiveWorkbook.ActiveSheet.Range("L8").Copy
ActiveWorkbook.Close SaveChanges:=True

Workbooks.Open (fpath2)
ActiveWorkbook.ActiveSheet.Cells(i, 9).PasteSpecial
ActiveWorkbook.Close SaveChanges:=True


Workbooks.Open "C:\Users\kairi\Downloads\評価\" & strFilename
ActiveWorkbook.ActiveSheet.Range("L9").Copy
ActiveWorkbook.Close SaveChanges:=True

Workbooks.Open (fpath2)
ActiveWorkbook.ActiveSheet.Cells(i, 10).PasteSpecial
ActiveWorkbook.Close SaveChanges:=True

strFilename = Dir()

Loop


End Sub

質問者からの補足コメント

• プログラムのコメントが少なくて伝わりにくいですが
  CommandButton1_Click()の部分がフォルダを参照させる部分
  CommandButton２_Click()の部分が出力ファイル選択
  CommandButton３_Click()の部分がファイル名取得しセルの内容をコピーして指定された別ブックへ転記するプログラムです

    補足日時：2019/06/28 05:29

No.3 回答者： tatsu99 回答日時： 2019/06/29 06:09

Workbooks.Open "C:\Users\kairi\Downloads\評価\" & strFilename

この箇所ですが、
Private Sub CommandButton1_Click()
で取得したフォルダのファイルをオープンするのではないでしょうか。
"C:\Users\kairi\Downloads\評価\" ではなく、「参照.Value」を使用すべきかと思いますが、いかがでしょうか。

No.2 回答者： WindFaller 回答日時： 2019/06/28 19:09

最初にマクロの基本。

同じ内容のコードは書かないことなのですが、
それも、ここではOpen-Close を繰り返すと、エラーが出そうな気がしてきます。
完全に造りそのものを変えてしまいましたので、評価しにくいとは思いますが、考え方の参考にしてみてください。

>どう書き直せばいいかご教授お願い致します。
造りそのものは、単純で、再帰もアルゴリズムも使っていません。
1.
'UserForm に組み込んではいませんが、フォルダーからのファイル名を検索する方法
'再帰の使い方は知っていますが、あえて辞めました。


なお、開発はUserForm上ではありませんので、いくぶん、甘い部分が残っているかもしれません。

'★の部分がユーザー設定

'//あえてサプルーチンにしてしまいました。その方が失敗が少ないからです。
Sub MakingFileList(Files)
　Dim Folders()
　Dim Pth As String
　Dim i As Long
　Dim Defpath As String
　Dim n As Long
　Defpath = Application.DefaultFilePath 'デフォルトファイルパス ★
　ReDim Preserve Folders(0)
　If InStrRev(Defpath, "\") = Len(Defpath) Then n = 1
　Folders(i) = Left(Defpath, Len(Defpath) - n)
　i = 1
　Pth = Dir(Defpath & "*.", vbDirectory)
　Do While Pth <> ""
　　If Pth <> "." And Pth <> ".." Then
　　　ReDim Preserve Folders(i)
　　　Folders(i) = Defpath & Pth
　　　i = i + 1
　　End If
　　DoEvents
　　Pth = Dir()
　Loop
　'--------------
　''Dim files() 'パラメータ側に移したので、使わない
　Dim p As Variant
　Dim j As Long
　Dim fn As String
　Const EXT As String = "xlsx" '拡張子　★
　For Each p In Folders
　 fn = Dir(p & "\" & "*." & EXT, vbNormal)
　 Do While fn <> ""
　 If Pth <> "." And Pth <> ".." Then
　　 ReDim Preserve Files(j)
　　 Files(j) = p & "\" & fn
　　 j = j + 1
　　End If
　　DoEvents
　　fn = Dir()
　 Loop
　Next
End Sub

'(配列変数 Files に格納されます)
'//
2.
'Open Close を繰り返す部分は、以下にすれば一回で済みます。

Private CommandButton3_Click()
Dim SrcBk As Workbook
　Dim DestBK As Workbook
　Dim i As Long, j As Long
　Dim strFilename '文字型は使えません。
　Dim HyokaPATH As String
　Dim fpath2 As String
　HyokaPATH = Application.DefaultFilePath　'★
If HyokaPATH Like "*\" Then Mid(HyokaPATH,1, Len(HyokaPATH) -1)
fpath2 = HyokaPATH & "\" & MyBook '★
　Dim Files() '取得 Call MakingFileList 用の変数
　Call MakingFileList(Files)
　Set DestBK = Workbooks.Open(fpath2)

　　'行を加算
　　i = 1
　　For Each strFilename In Files
　　On Error Resume Next
　　Set SrcBk = Workbooks.Open(strFilename, False, True) 'ReadOnlyにしました。
　　With SrcBk
　　　.ActiveSheet.Range("J2").Copy DestBK.ActiveSheet.Cells(i, 1)
　　　.ActiveSheet.Range("D2").Copy DestBK.ActiveSheet.Cells(i, 2)
　　　.ActiveSheet.Range("K1").Copy DestBK.ActiveSheet.Cells(i, 3)
　　　.ActiveSheet.Range("M1").Copy DestBK.ActiveSheet.Cells(i, 4)
　　　.ActiveSheet.Range("O1").Copy DestBK.ActiveSheet.Cells(i, 5)
　　　.ActiveSheet.Range("L1").Copy DestBK.ActiveSheet.Cells(i, 6)
　　　.ActiveSheet.Range("L6").Copy DestBK.ActiveSheet.Cells(i, 7)
　　　.ActiveSheet.Range("L7").Copy DestBK.ActiveSheet.Cells(i, 8)
　　　.ActiveSheet.Range("L8").Copy DestBK.ActiveSheet.Cells(i, 9)
　　　.ActiveSheet.Range("L9").Copy DestBK.ActiveSheet.Cells(i, 10)
　　　.Close False
　　　i = i + 1
　　End With
　　If Error <> 0 Then
　　 Debug.Print strFilename 'エラーつまり、プロテクトが掛かっている場合など
　　 End If
　　On Error GoTo 0
　Next
End Sub
'//

No.1 回答者： fujillin 回答日時： 2019/06/28 09:48

こんにちは

ヒントのみですが・・・
（実際に実行して、動作確認はしてはいませんので、悪しからず）

1）
原状は、Dir関数でエクセルファイルのみを指定しているので、サブフォルダなどは無視されていることになります。
例えば、指定フォルダ内のファイル/フォルダを順に処理して、サブフォルダが見つかったら「そのフォルダ内を検索」するような仕組みにしておけばよいですよね。
そのまま記述すると、「サブフォルダ内にサブフォルダが見つかったら～～」と入れ子の記述を続けなければならなくなりますので、これを回避するために。「サブフォルダが見つかったら、フォルダを引数にして自分自身を呼び出す（再帰）」ような仕組みにしておくのが効率が良いでしょう。
＜参考＞
https://www.moug.net/tech/exvba/0060088.html

2）
原因がはっきりとしないので、何が適切なのか測りかねますが、二種類の方法を考えてみました。
①openイベントで実行されるマクロが原因の場合、イベントの発生を停止しておけばよさそう
　Application.EnableEvents = False
とすることでイベントを無効にできますので、openイベントが発生しなくなります。
（最後に元に戻しておくのを忘れずに）
＜参考＞
https://docs.microsoft.com/ja-jp/office/vba/api/ …

②ブックオープン時にマクロを無効化する
エクセルのセキュリティレベルでマクロを無効化したのと同じ状態にしてから、ブックを開きます。
＜参考＞
https://docs.microsoft.com/ja-jp/office/vba/api/ …

開いたブック内のマクロのせいではなく、2重に開く等のエラーが発生するのであれば、ファイルを開く前に「既に開いているかのチェックを行う」か、「On Errorステートメントでエラー処理を行う」ようにしておくか等で回避できるものと思います。


ご質問内容には直接関係はありませんが、ご提示の「CommandButton3_Click」でセル値の転記の際に、一つ転記するごとに転記元、転記先のファイルを開く/閉じるを繰り返していますが、あまりにも効率が悪すぎます。（ファイルの開閉には時間が掛かりますので）
　・転記元、転記先のファイルを開く
　・必要なセル値（複数）を順に全て転記
　・転記元、転記先のファイルを閉じる
だけで済むはずです。

実際には、転記先のファイルは次の転記元ファイルの処理の際にも開くことになるのでしょうから、処理全体に渡って開いておいて、処理終了時に（一度だけ）閉じれば済むものと思われます。