質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

89.13%

【ExcelVBA】集計対象のファイルを重複なく一覧表にしたい

解決済

回答 1

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 552

MitsuhiroN

score 12

 前提・実現したいこと

Excel VBAで、複数の階層に格納された集計対象となるファイルを、重複したファイルは更新日時が最新のものに置き換え、ファイル名・パス名・フルパスを項目名にしたテーブルにしたいと考えております。

その為に、FileSystemObjectで取得した全FileオブジェクトをCollectionに格納し、そのCollection内で重複したファイルの内、古い方を除外して出力、という流れで考えました。

複数のチームが記入した記録表(Excel)を以下の階層構造で格納しています。
<チーム1> — <内部R/顧客R> —<機能A/機能B>-<指摘依頼中/完了etc・・・> — *.xlsx
<チーム2>・・・

チームごとに内部Rフォルダ・顧客Rフォルダ、それぞれの配下に機能ごとのフォルダ、その下にレビューの進捗度で更にフォルダ分け(依頼中・完了等)して、最後の階層に該当記録表を格納しています。
大まかにこのルールで格納されているのですが、同じファイルが違う進捗フォルダに格納されていることがあり、
⇒ Aファイルが〈指摘依頼中フォルダ〉と〈完了フォルダ〉双方に同名で格納。更新日時は完了フォルダの方が新しい。

重複したファイル名は更新日時の新しい方に上書きして取得したいです。
また、ほぼ進捗自体が完了した機能に関しては進捗分けもしておらず、直にファイルが置かれていることもあります。

 発生している問題

重複の上書きがうまくできません。
全ファイルを一度Collectionに格納してから比較、という流れにしたいのですが、フォルダ単位で比較を実施してしまうが為に削除が実施できていないようです。

 該当のソースコード

Public Sub GetSubFolder(ByRef teams_basefolder As String)
 'teams_basefolderに各チームの内部/顧客Rまでのフォルダパスを受け取る
Dim fso As New FileSystemObject
Set fso = New FileSystemObject

Dim firstfolder As folder
Dim firstSubfolders As folders
Dim firstSubfolder As folder
Dim firstfiles As files
Dim firstfile As file

Dim folder As folder
Dim folders As folders
Dim fls As files
Dim fl As file
Dim fileCollection As New Collection

Set firstfolder = fso.GetFolder(teams_basefolder)
Set firstfiles = firstfolder.files
For Each firstfile In firstfiles
    If firstfile.Name Like "内Rev記録*.xlsx" _
    And firstfile.Name Like "Rev記録*.xlsx" _
    And firstfile.Name <> "内Rev記録_設計書名.xlsx" Then
  '記録表のファイル名のフォーマット。テンプレート用のファイルも一緒に格納されているため除外
        With fileCollection
            .Add firstfile
        End With
    End If
Next

Set firstSubfolders = firstfolder.SubFolders

For Each firstSubfolder In firstSubfolders
    Set fls = firstSubfolder.files

    For Each fl In fls
        If fl.Name Like "内Rev記録*.xlsx" _
        Or fl.Name Like "Rev記録*.xlsx" Then
            With fileCollection
                .Add fl
            End With
        End If
    Next

Next
    For Each fl In fls
        If fl.Name Like "内Rev記録*.xlsx" Or fl.Name Like "Rev記録*.xlsx" Or _
           fl.Name <> "内Rev記録_設計書名.xlsx" Then
            With fileCollection
                .Add fl
            End With
        End If
    Next

    For Each folder In fso.GetFolder(teams_basefolder).SubFolders
        If folder.Name Like "*old*" Then GoTo goNext
            Call GetSubFolder(teams_basefolder & "\" & folder.Name)
goNext:
    Next

Dim col As New Collection
Set col = compareBothCollection(flCol)
Call pasteSpecFiles(col)


Set fso = Nothing
Set basefolder = Nothing
Set fls = Nothing
Set flCol = Nothing
Set col = Nothing

End Sub


Private Sub pasteSpecFiles(ByRef col_file As Collection)
Dim startLine As Long
Dim F As file

With allFiles
    startLine = .Cells(.Rows.count, allFilesSh.絶対パス).End(xlUp).Row

    For i = 1 To col_file.count
        Set F = col_file.Item(i)
        .Cells(startLine + i, allFilesSh.絶対パス).Value = F.path
        .Cells(startLine + i, allFilesSh.フォルダ).Value = F.parentFolder
        .Cells(startLine + i, allFilesSh.ファイル名).Value = F.Name
        Set F = Nothing
    Next
End With
End Sub



Private Function compareBothCollection(ByRef colfiles As Collection) As Collection

Dim bufColfile As New Collection
Dim fl As file
Dim fl2 As file
Dim i As Long, j As Long

Set bufColfile = colfiles

For i = 1 To colfiles.count
    For j = 1 To bufColfile.count
        Set fl = colfiles(i)
        Set fl2 = bufColfile(j)

        If fl.Name = fl2.Name Then
            If fl.DateLastModified < fl2.DateLastModified Then
                colfiles.Remove (i)
            Else: GoTo Skip
            End If
        Else: GoTo Skip
        End If
Skip:
        Set fi = Nothing
        Set fl2 = Nothing
    Next
Next
Set compareBothCollection = colfiles

End Function

どういう処理の流れにすればよいかがわからず、質問させていただきました。
以上、よろしくお願いいたします。

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 1

checkベストアンサー

+1

直接の回答にはなっていませんが。。。

全ファイルを一度Collectionに格納してから比較、という流れにしたいのですが

そもそもこれはどういった理由からなのでしょうか?

もし自分が作るならですが、次のように考えます。

  • CollectionではなくDictionaryを使う
  • Dictionaryはファイル名をキーにする
  • Dictionaryにファイルが存在するかExistsでチェックする
  • 存在していたら更新日付を比較、新しければ同じキーに更新する
  • 存在していなかったらファイル名をキーに新しく登録する
  • 全ファイル終わったら出力

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2018/10/18 16:39

    いえ、方法としてCollectionにこだわっているわけではないです。
    試行錯誤で思いついた方法なので。ただ、最終的にフルパスとフォルダとファイル名とをテーブルに貼り付けすることを考えると、できればFileオブジェクトとして終始扱いたいなと思いまして、それだったらCollectionかなと。
    Dictionaryの場合itemにオブジェクトを格納することが可能だったか・・と思ったもので、現状Collectionで考えています。

    キャンセル

  • 2018/10/18 16:47

    Dictionaryにもオブジェクトは格納できます。
    手前味噌ですが、過去質問でDictionaryを使った回答をしていますので参考まで。
    https://teratail.com/questions/149008
    この質問の回答では多重Dictionaryですが、fileオブジェクトも格納可能と思います。

    キャンセル

  • 2018/10/18 19:46

    私もDictionaryをお勧めします。
    下記サイトでDictionaryにオブジェクトを格納できることを知りました。
    http://vba.ym326.com/2017/12/11/post-22/

    キャンセル

  • 2018/10/19 07:46

    お二方ありがとうございます!

    オブジェクトが格納可能なのが確認できました!

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 89.13%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる