Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Pro : その他)
サブフォルダにある、たくさんのExcelファイルのセルの値を書き出したい
投稿日時: 20/09/12 17:46:45
投稿者: rara-haha

サブフォルダに同じ書式のExcelファイルがあります。
そのExcelファイルの「集計」というシートの「A1」セルの値のみを書き出したいのですが、どのように記述すると良いのでしょうか。
 
階層は下記のような感じです。
 
D:\Desktop\test\Aさん\01.xlsx
D:\Desktop\test\Bさん\02.xlsx
D:\Desktop\test\Cさん\05.xlsx
 
 
「D:\Desktop\test」までは固定ですが、その中にたくさんのフォルダやデータがあります。
その中には画像などExcelファイル以外もあります。
 
以上よろしくお願いします。
 
 
 
Excelのバージョン:Excel365

回答
投稿日時: 20/09/12 18:34:07
投稿者: WinArrow
投稿者のウェブサイトに移動

まず、コード作成依頼は、禁止されているので、コードをていきょうしませんが、
ヒントだけ
 
A処理
目的のファイルを探すまでは、FSOを使います。
目的のファイルのファイル名をできたら、B処理実行します。
 
B処理
そのファイルを開き、目的のセルのデータを複写します。
複写収容後、ファイルを閉じます。
 
 
A処理のFSOの利用は検索してみてください。
 
B処理は、マクロの記録でコードが作成できます。
チャレンジしてみましょう

回答
投稿日時: 20/09/12 21:50:10
投稿者: simple

既に指摘いただいているとおりです。補足情報です。
 
こちらのサイトの「即効テクニック」にある
「サブフォルダを含めてファイル一覧を取得する(Dir関数の再帰呼び出し)」
https://www.moug.net/tech/exvba/0060088.html
の、特に、後半部分が参考になるでしょう。
 
また、File System Objectについては、
FileSystemObject
http://officetanaka.net/excel/vba/filesystemobject/index.htm
がまとまっていると思います。
 
トライしてみて、不明点があればまたコメントして下さい。

投稿日時: 20/09/13 00:35:16
投稿者: rara-haha

WinArrowさん、simpleさん、アドバイスありがとうございます。
 
コード作成依頼は、禁止されているとは知りませんでした。
大変失礼しました。
 
あれやこれや試し、VBAがゴチャゴチャになっていたので、それをここに書くのも…、
しかしコードを何も書かずにお聞きするのも…と思いながらもお聞きしてしまいました。
 
 
FSOとは「FileSystemObject」のことですね。
 
即効テクニックを参考に作成してみましたが、ここまで書いて行き詰まってしまいました。
 
 
-------------------------------------------------------
 
Sub Sample1(Path As String)
 
 
    Dim buf As String, f As Object
    buf = Dir(Path & "\*.*")
    Do While buf <> ""
        cnt = cnt + 1
        Cells(cnt, 1) = buf
        buf = Dir()
    Loop
    With CreateObject("Scripting.FileSystemObject")
        For Each f In .GetFolder(Path).SubFolders
            Call Sample1(f.Path)
        Next f
    End With
End Sub
 
 
 
Sub Test()
    cnt = 0
    Call Sample1("D:\Desktop\test")
End Sub
 
-------------------------------------------------------
 
Cells(cnt, 1) = buf
でファイル名が書き出されるのですが、
Cells(cnt, 2) にA1セルのデータを書き出すのが出来ません。
 
記録マクロでもトライしてみましたが、うまくいきませんでした。
 
Cells(cnt, 2) = buf("Sheet1").Range("A1")

Cells(cnt, 2) = Cells(cnt, 1) ("Sheet1").Range("A1")
みたいに単純に書き出せれば…と思ったのですが、無理でした。

回答
投稿日時: 20/09/13 08:13:17
投稿者: simple

ご苦労様です。
 
> 記録マクロでもトライしてみましたが、うまくいきませんでした。
そうですか、どのようなものを記憶されましたか?
実際のものを見せてください。
 
条件にあう特定のブックを一つだけでよいので、下記の動作を記録して
それをこちらにアップしてみてください。
(1)それを開いて
(2)そのExcelファイルの「集計」というシートの「A1」セルの値を、
   書込先のシートの予定している場所にコピーする
(3)そのブックを閉じる。
というようなことだと思います。
 
ボトムアップでひとつのブックを相手にした処理から固めましょう。

回答
投稿日時: 20/09/13 08:39:40
投稿者: WinArrow
投稿者のウェブサイトに移動

>Cells(cnt, 2) にA1セルのデータを書き出すのが出来ません。
 
それは当然のことながら、ブックを開くことができていないので、
セルの情報は取得できませんね?
 
利用者の環境やら、やりたいことが違うので、
即効テクニックのコードそのままを適用して無理です。
FSOの部分は、追加してあるようですが、
 
私見ですが、
折角、FSOを使っているのですから、FSOだけでもできます。
ファイル検索部分を、Sample2という名前でプロシジャ作成すればよいと思います。
ここまで私見です。
 
まずは、対象のブックを開く〜取得〜閉じる
プロシジャお作成してみましょう。
 
 
 

回答
投稿日時: 20/09/13 10:09:01
投稿者: WinArrow
投稿者のウェブサイトに移動

ちょっと、気になったところ
  
Sample1プロシジャの
前半に
Dir関数で、ファイル名を取得しているところがあります。
  
Testプロシジャから
Call したときにも実行されます。
  
このマクロブックは、指定のフォルダ内に存在するのですか?
自ブック名がセルに代入されます。
また、Excelファイル以外もセルに代入されます。
問題があったら修正しましょう。
 

回答
投稿日時: 20/09/13 13:26:38
投稿者: WinArrow
投稿者のウェブサイトに移動

参考意見
 
「即効テクニック」のコードは、
Dir関数の使い方から始まっているため、
FSOを使う例でもDir関数を使っています。
 
これがダメというわけではありませんが、
折角FSOを使うのですから
FSOで統一したほうがスマートだと思います。
 

引用:

    With CreateObject("Scripting.FileSystemObject")
         For Each f In .GetFolder(Path).SubFolders
             Call Sample1(f.Path)
         Next f
     End With

を少し、改変して
 
> With CreateObject("Scripting.FileSystemObject")
を外に出して、
1回だけ実行します。→Testプロシジャ内で実行
 
で、
> With CreateObject("Scripting.FileSystemObject")

    With FSO
に変更します。
 
> Call Sample1(f.Path)

             Call Sample2(f.Path)
に変更します。
 
Sample2プロシジャ
sub Sample2(Path As string)
    With FSO
        For Each Fn In .GetFoldes(path).Files
            If Fn.name Like "*.xlsx" Then
               'ここにファイル開く〜閉じるまでを記述
            End If
        Next
    End With
End Sub
 
のようにすれば再帰処理不要になります。
  

投稿日時: 20/09/13 23:22:37
投稿者: rara-haha

simpleさん、WinArrowさん、いろいろと教えて頂きありがとうございます。
 
しかしFileSystemObjectが、初めてで難しくなかなか思うように進みません。
 
------------------------------------------------------------
simpleさんへ
  
> > 記録マクロでもトライしてみましたが、うまくいきませんでした。
> そうですか、どのようなものを記憶されましたか?
> 実際のものを見せてください。
 
 
    Sheets("集計").Select
  Range("A1").Select
    Selection.Copy
    Windows("テスト.xlsm").Activate
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
 
01.xlsxというブックを開く作業をしたのですが、そちらが記録されていません。
------------------------------------------------------------
 
WinArrowさんへ
 
下記で合ってますでしょうか。違っているのでしょうね。
エラーが出てしまいます。。
 
Sub Sample1(Path As String)
  
  
    Dim buf As String, f As Object
    buf = Dir(Path & "\*.*")
    Do While buf <> ""
        cnt = cnt + 1
        Cells(cnt, 1) = buf
        buf = Dir()
    Loop
 
End Sub
  
  
  
Sub Test()
    Dim f As Object
    cnt = 0
      
    With FSO
         For Each f In .GetFolder(Path).SubFolders
             Call Sample2(f.Path)
         Next f
    End With
    Call Sample1("D:\Desktop\test")
End Sub
 
 
Sub Sample2(Path As String)
    With FSO
        For Each Fn In .GetFoldes(Path).Files
            If Fn.Name Like "*.xlsx" Then
               'ここにファイル開く〜閉じるまでを記述
               MsgBox "テスト"
            End If
        Next
    End With
End Sub
 
上記のVBAを実行すると
「For Each f In .GetFolder(Path).SubFolders」のところで止まり
『オブジェクトが必要です。』と表示されます。
 
 
 
'ここにファイル開く〜閉じるまでを記述
は、またこちら、モーグのサイトですが…
https://www.moug.net/tech/exvba/0060037.html
を参考に修正してみましたが、サブフォルダのデータが取れず、また行き詰まり…
 
 
Sub Sample9()
    Dim i As Long, buf As String, Target As String
    Const Path = "D:\Desktop\test\"
    buf = Dir(Path & "*.xlsx")
    Do While buf <> ""
        Target = "'" & Path & "[" & buf & "]Sheet1'!R1C1"
        i = i + 1
        Cells(i, 1) = buf
        Cells(i, 2) = ExecuteExcel4Macro(Target)
        buf = Dir()
    Loop
End Sub
 
 
まだExcelファイルだけを抽出するところは保留です。
そちらは上記のことが出来てから考えようかと…。

回答
投稿日時: 20/09/14 11:01:34
投稿者: WinArrow
投稿者のウェブサイトに移動

いろいろのコードを参考にしているようですが、
各々の思想が違うので、頭の切り替えが難しいと思います。
 
私は、FSOだけで統一することをお勧めします。
 
コード作成を優先するのではなく、状況の整理をすると
処理の組み立てができると思いますので、以下を参考に整理してみたらいかがでしょう。
 
まず、物事を整理する時は、概要から入ります。
【全体の佇まい】
1.目的のフォルダがあります。
  その中には、幾つかのサブフォルダ1があります。
  このステップでは、初期設定と目的のフォルダ内のサブフォルダ検索、終了処理にないます。
 
2.サブフォルダ1の中には、
 幾つかのファイルと、幾つかのサブフォルダ2があります。
 このステップでは、1つのサブフォルダだけ対象と考えます。
 ファイル検索とサブフォルダ検索の2つのループになります。
 
3.サブフォルダ2の中には、
  幾つかのファイルがあります。
 このステップでは、1つのサブフォルダだけ対象と考えます。
 
4.サブフォルダ1の中のファイル、サブフォルダ1の中のファイルは、
 拡張子:xlsxのみ対象とします。
 このステップでは、1つのファイルだけを対象と考えます。
 各々には、シート名:集計が存在し、そのシートのセルA1を自ブックのシート:○○に転記します。
 
 自ブックのシート:○○のレイアウト
 A列:複写元ブックのフルパス
 B列:複写元ブックのシート:集計のA1セルの値
 
このような構造ができたならば、
 
各々のステップで、変数とする項目を決めます。
 
例えば
4のステップでは、転送元ファイルのパスを変数とします。
  
3、2、1のステップでは、上位のフォルダ名を変数とします。
 
 
次に、
4→3→2→1の順番にコーディングしていきますが、
一挙にコーでイングするのではなく
 
1つのステップをテストして、OKになったら、上のステップへと進めます。
 
なお、ステップ3は、ステップ2を再帰処理化することで、ステップ2に含めることができます。

回答
投稿日時: 20/09/14 11:51:32
投稿者: WinArrow
投稿者のウェブサイトに移動

参考コード
 
Public FSO As Object
Public cnt As Long
Public mySheet As Worksheet
 
 
Sub test()
    Set mySheet = ThisWorkbook.Sheets(1)
    cnt = 1
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Call GetFolder(path:="D:\Desktop\test")
    Set FSO = Nothing
End Sub
 
 
Private Sub GetFolder(ByVal path As String)
Dim fol, File
    With FSO
        For Each File In .GetFolder(path).Files
            If File.Name Like "*.xlsx" Then
                Call Getcell(path:=File.path)
            End If
         Next File
        For Each fol In .GetFolder(path).SubFolders
            Call GetFolder(fol.path)
        Next
    End With
End Sub
 
Private Sub Getcell(ByVal path As String)
    With Workbooks.Open(Filename:=path)
        mySheet.Cells(cnt, "A").Value = .Name
        mySheet.Cells(cnt, "B").Value = .Sheets("集計").Range("A1").Value
        .Close False
        cnt = cnt + 1
    End With
End Sub

投稿日時: 20/09/14 13:06:26
投稿者: rara-haha

WinArrowさん、ありがとうございます。
 
解説、サンプルコード、事細かにありがとうございます。
 
本当、頭の中がこんがらがっていました。
昨日、あーでもない、こーでもないと訳の分からない方向に行ったりし、整理できない状況に。
 
無駄のない、シンプルなコード素晴らしい。。。
私が求めていたデータが奇麗に書き出されてきました。
 
どんな動きをしているのか今度途中止めながらじっくり見させて頂きます。
 
本当、助かりました。
これで業務が大幅に短縮できそうです。
数日間大変お世話になりました。
 
 
simpleさんもありがとうございました。