フォルダの中にあるexcelファイルを再帰的に処理したい


フォルダの中にExcelのファイルが複数あり、さらにそのフォルダの中にフォルダがありexcelファイルが存在するとします。全てのExcelファイルのA1からA10まで数値が入っているとします。その数値を足した値を新規のexcelファイルをデスクトップに作りA1から順にデータを書き込んでいきたいとします。

例えばX,Y,ZファイルがXYZフォルダにはいっています。XYZフォルダにはXXフォルダも入っていて、フォルダの中にはXX,YY,ZZファイルがあります。各ファイルのA1からA10までの合計はX=10,Y=20,Z=30,XX=15,YY=25,ZZ=35となったとします。デスクトップに新規Excelファイルを作りA列にファイル名、B列に合計に表示したいという場合、どのような技術を使って、どのような関数を使って、どのような処理順で処理すればいいのでしょうか?VBでアプリケーションを作ればそのような処理はできるかと思いますが、どのような関数を使って、どのような処理順で処理していったらいいか教えてください。

回答の条件
  • URL必須
  • 1人2回まで
  • 登録:2007/11/29 17:52:26
  • 終了:2007/12/04 17:58:36

ベストアンサー

id:ardarim No.4

ardarim回答回数892ベストアンサー獲得回数1422007/11/30 01:28:14

ポイント50pt

サンプルです。

COMオブジェクトを使わずExcelのネイティブ機能で攻めてみました。

Option Explicit
Option Base 1

Private Declare Function SHGetSpecialFolderPath Lib "shell32.dll" Alias "SHGetSpecialFolderPathA" _
    (ByVal hwndOwner As Long, ByVal lpszPath As String, ByVal nFolder As Long, ByVal fCreate As Long) As Long

' 起点となるフォルダ名
Const rootFolder As String = "c:\temp\"

Sub MakeSum()

    Dim summaryFileName As String
    Dim summaryBook As Workbook
    Dim summarySheet As Worksheet
    Dim szDesktopPath As String
    
    Application.ScreenUpdating = False
    
    Set summaryBook = Workbooks.Add
    Set summarySheet = summaryBook.Worksheets(1)
    
    Call RecursiveSum(summarySheet, 1, rootFolder)
    With summarySheet
        .Range(.Columns(1), .Columns(2)).AutoFit
    End With

    ' デスクトップフォルダの取得
    szDesktopPath = String$(260, " ")
    If SHGetSpecialFolderPath(0, szDesktopPath, 0, 0) <> 0 Then
        szDesktopPath = Left$(szDesktopPath, InStr(szDesktopPath, vbNullChar) - 1) & "\"
    Else
        szDesktopPath = rootFolder
    End If

    ' 保存
    summaryFileName = szDesktopPath & "summary.xls"
    If Dir(summaryFileName) <> "" Then
        If MsgBox(summaryFileName & "は既に存在します。上書きしますか?", vbYesNo) = vbNo Then
            summaryBook.Close False
            Exit Sub
        End If
        Kill summaryFileName
    End If
    summaryBook.SaveAs summaryFileName
    summaryBook.Close False

    Application.ScreenUpdating = True

End Sub

' フォルダ内のXLSファイルの処理とサブフォルダの再帰呼出し
Function RecursiveSum(ByRef summarySheet As Worksheet, ByVal r As Long, ByVal baseFolder As String) As Long

    Dim i As Long, m As Long
    Dim n As Long
    Dim xlsFilePath As String
    Dim subFolders() As String
    
    n = 0

    ' フォルダ内のXLSファイルをリストアップ
    xlsFilePath = Dir(baseFolder & "*.xls", vbNormal)
    Do While xlsFilePath <> "" And xlsFilePath <> ThisWorkbook.Name
        summarySheet.Cells(r + n, 1).Value = baseFolder & xlsFilePath
        summarySheet.Cells(r + n, 2).Value = GetSum(baseFolder & xlsFilePath)
        n = n + 1
        xlsFilePath = Dir()
    Loop
    
    ' フォルダ内のサブフォルダをリストアップ
    m = 0
    xlsFilePath = Dir(baseFolder, vbDirectory)
    Do While xlsFilePath <> ""
        If Left$(xlsFilePath, 1) <> "." Then
            If GetAttr(baseFolder & xlsFilePath) And vbDirectory Then
                m = m + 1
                ReDim Preserve subFolders(m)
                subFolders(m) = baseFolder & xlsFilePath & "\"
            End If
        End If
        xlsFilePath = Dir()
    Loop
    
    ' 各サブフォルダを再帰的に呼出し
    For i = 1 To m
        n = n + RecursiveSum(summarySheet, r + n, subFolders(i))
    Next i
    
    ' 処理したファイル数を返す
    RecursiveSum = n

End Function

' ファイルを開いてA1:A10の合計を得る
Function GetSum(ByVal xlsFilePath As String) As Variant

    With Workbooks.Open(xlsFilePath, 0, True)
        GetSum = WorksheetFunction.Sum(.Worksheets(1).Range("A1:A10"))
        .Close False
    End With

End Function

URLはダミーです。

http://q.hatena.ne.jp/1196326344

id:popattack

コードまで書いて頂いてありがとうございます!試してみます!

2007/12/04 17:57:46

その他の回答(3件)

id:taknt No.1

きゃづみぃ回答回数13537ベストアンサー獲得回数11982007/11/29 19:29:04

http://www.excel-jiten.net/formula/ref_other_books.html

エクセルでほかのブックを参照するには

='パス名[ブック名]シート名'!セル名

とします。

これで セルに入れていけばいいでしょう。

id:popattack

これだと1000フォルダに5000ファイルあったときに無理があります。そういうことをしたくないのでアイディアを聞いているんです。

2007/11/29 20:03:55
id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912007/11/29 19:33:38

ポイント50pt

一応今回の内容を実現する VBA(マクロ)の例です。

下記のコードを標準モジュールに入れたファイルを作成し、マクロの実行から mySum を実行してみてください。

Option Explicit

Public dataLine As Long

'-------------------------------------------
Sub mySum()
'-------------------------------------------
    Dim MyFolder As String
    
'--- フォルダを選択
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then  'アクションボタンがクリックされた
            MyFolder = .SelectedItems(1)
        Else                'キャンセルボタンがクリックされた
            MyFolder = "CANCEL"
        End If
    End With
    
    With ThisWorkbook
        .Worksheets.Add before:=.Worksheets(1)
    End With
    
    dataLine = 1
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    checkFolder fso, MyFolder


'--- 新規ファイルとして保存
    Dim dstFile As String
    dstFile = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\集計結果.xls"
    
    With ThisWorkbook
        .Worksheets(1).Copy
        ActiveWorkbook.SaveAs dstFile
        Workbooks("集計結果.xls").Close
        Application.DisplayAlerts = False
        .Worksheets(1).Delete
        Application.DisplayAlerts = True
    End With
    
End Sub

'-------------------------------------------
Sub checkFolder(fso As Object, filePath As String)
'-------------------------------------------
'--- フォルダ下のファイルを検索して集計
    Dim f As Object
    Dim d As Object
    
    For Each f In fso.getFolder(filePath).Files
        If UCase(fso.GetExtensionName(f.Path)) = "XLS" Then
            sumOneFile f.Path
        End If
    Next
    
    For Each d In fso.getFolder(filePath).SubFolders
        checkFolder fso, d.Path
    Next
End Sub

'-------------------------------------------
Sub sumOneFile(filePath As String)
'-------------------------------------------
'--- ファイルのデータを集計
    With Workbooks.Open(filePath)
        ThisWorkbook.Worksheets(1).Cells(dataLine, "A").Value = filePath
        ThisWorkbook.Worksheets(1).Cells(dataLine, "B").Value _
            = Application.WorksheetFunction.Sum(.Worksheets(1).Range("A1:A10"))
        .Close
    End With
    dataLine = dataLine + 1
End Sub

http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_040.html

不明な点はコメントにて対応しますので、コメントを有効にお願いします。

id:popattack

コードまで書いて頂いてありがとうございます!試してみます!

2007/12/04 17:57:41
id:degucho No.3

degucho回答回数245ベストアンサー獲得回数622007/11/29 19:36:46

VBのバージョン表記がありませんが、6.0だと仮定すると

・Dir関数またはFileSystemObjectでフォルダツリーを再帰的に走査

・OLE操作でworksheet.Range.valueを取得して計算

・OLE操作で新規ブック作成

が定石かと思います


いずれも「VB フォルダ 再帰」「VB Excel」などでネット検索すると

サンプルが沢山出てきますので頑張ってください

http://hanatyan.sakura.ne.jp/

id:ardarim No.4

ardarim回答回数892ベストアンサー獲得回数1422007/11/30 01:28:14ここでベストアンサー

ポイント50pt

サンプルです。

COMオブジェクトを使わずExcelのネイティブ機能で攻めてみました。

Option Explicit
Option Base 1

Private Declare Function SHGetSpecialFolderPath Lib "shell32.dll" Alias "SHGetSpecialFolderPathA" _
    (ByVal hwndOwner As Long, ByVal lpszPath As String, ByVal nFolder As Long, ByVal fCreate As Long) As Long

' 起点となるフォルダ名
Const rootFolder As String = "c:\temp\"

Sub MakeSum()

    Dim summaryFileName As String
    Dim summaryBook As Workbook
    Dim summarySheet As Worksheet
    Dim szDesktopPath As String
    
    Application.ScreenUpdating = False
    
    Set summaryBook = Workbooks.Add
    Set summarySheet = summaryBook.Worksheets(1)
    
    Call RecursiveSum(summarySheet, 1, rootFolder)
    With summarySheet
        .Range(.Columns(1), .Columns(2)).AutoFit
    End With

    ' デスクトップフォルダの取得
    szDesktopPath = String$(260, " ")
    If SHGetSpecialFolderPath(0, szDesktopPath, 0, 0) <> 0 Then
        szDesktopPath = Left$(szDesktopPath, InStr(szDesktopPath, vbNullChar) - 1) & "\"
    Else
        szDesktopPath = rootFolder
    End If

    ' 保存
    summaryFileName = szDesktopPath & "summary.xls"
    If Dir(summaryFileName) <> "" Then
        If MsgBox(summaryFileName & "は既に存在します。上書きしますか?", vbYesNo) = vbNo Then
            summaryBook.Close False
            Exit Sub
        End If
        Kill summaryFileName
    End If
    summaryBook.SaveAs summaryFileName
    summaryBook.Close False

    Application.ScreenUpdating = True

End Sub

' フォルダ内のXLSファイルの処理とサブフォルダの再帰呼出し
Function RecursiveSum(ByRef summarySheet As Worksheet, ByVal r As Long, ByVal baseFolder As String) As Long

    Dim i As Long, m As Long
    Dim n As Long
    Dim xlsFilePath As String
    Dim subFolders() As String
    
    n = 0

    ' フォルダ内のXLSファイルをリストアップ
    xlsFilePath = Dir(baseFolder & "*.xls", vbNormal)
    Do While xlsFilePath <> "" And xlsFilePath <> ThisWorkbook.Name
        summarySheet.Cells(r + n, 1).Value = baseFolder & xlsFilePath
        summarySheet.Cells(r + n, 2).Value = GetSum(baseFolder & xlsFilePath)
        n = n + 1
        xlsFilePath = Dir()
    Loop
    
    ' フォルダ内のサブフォルダをリストアップ
    m = 0
    xlsFilePath = Dir(baseFolder, vbDirectory)
    Do While xlsFilePath <> ""
        If Left$(xlsFilePath, 1) <> "." Then
            If GetAttr(baseFolder & xlsFilePath) And vbDirectory Then
                m = m + 1
                ReDim Preserve subFolders(m)
                subFolders(m) = baseFolder & xlsFilePath & "\"
            End If
        End If
        xlsFilePath = Dir()
    Loop
    
    ' 各サブフォルダを再帰的に呼出し
    For i = 1 To m
        n = n + RecursiveSum(summarySheet, r + n, subFolders(i))
    Next i
    
    ' 処理したファイル数を返す
    RecursiveSum = n

End Function

' ファイルを開いてA1:A10の合計を得る
Function GetSum(ByVal xlsFilePath As String) As Variant

    With Workbooks.Open(xlsFilePath, 0, True)
        GetSum = WorksheetFunction.Sum(.Worksheets(1).Range("A1:A10"))
        .Close False
    End With

End Function

URLはダミーです。

http://q.hatena.ne.jp/1196326344

id:popattack

コードまで書いて頂いてありがとうございます!試してみます!

2007/12/04 17:57:46

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません