[[20170223003629]]　『複数ブックのデータをまとめるマクロのデータが重』（のんさびぃ）　ページの最後に飛ぶ

『複数ブックのデータをまとめるマクロのデータが重なってしまう』（のんさびぃ）

 長年引き継いで使われている文書中で、複数ブック（20~30ブック）のデータをまとめるというマクロがあるのですが、データが重なって抽出されてしまい、２行しか表示されません。
 各ブックがちゃんと開かれるという動作は確認できますし、エラーも出ません。
 どこを直せばデータが重ならないようになるのでしょうか？
 コードは以下になります。

 'This function is used to track all the excel sheets and store them in the Master file

 Sub updateTrackingSheet()

        'Declaring Variables
        Dim wbk As Workbook
        Dim fileName As String
        Dim myFile As String
        Dim Path As String
        Dim erow
        Dim sht As Worksheet
        Dim LastRow As Long
        Dim LastColumn As Long
        Dim StartCell As Range
        Dim wsheetRange As Range
        Dim dRange As Range
        Dim msg As String
        Application.DisplayAlerts = False
        Application.AskToUpdateLinks = False

        'Set Path Here
        Path = Application.ActiveWorkbook.Path & "\"
        fileName = Dir(Path & "*.xlsm")

        Do While Len(fileName) > 0
        If (fileName = "MasterTracker Projections.xlsm") Then
        Exit Do

        End If

        Set wbk = Workbooks.Open(Path & fileName)

        'Setting Last Saved Date in cell B41

        Range("A17:L17").Copy
        wbk.Close

        erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

        'Pasting values from individual excel files into Master
        erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        ActiveSheet.Paste Destination:=Worksheets("Summary").Range(Cells(erow, 1), Cells(erow, 12))
        Columns("A:L").Select
        Selection.EntireColumn.AutoFit
        fileName = Dir

        Loop

        'Repeating Procedure for files in subfolder
        Call Recurse(Path)

        'Msg on Completion
        msg = MsgBox("Tracking Sheet Updated Successfully", vbOKOnly)

 End Sub

        'Function to perform operation in multiple subfolders
        Public Function Recurse(sPath As String) As String

            Dim fso As New FileSystemObject
            Dim myFolder As Folder
            Dim mySubFolder As Folder
            Dim wbk As Workbook
            Dim sFilename As String
            Dim erow
            Dim sht As Worksheet
            Dim LastRow As Long
            Dim LastColumn As Long
            Dim StartCell As Range
            Dim wsheetRange As Range
            Application.DisplayAlerts = False
            Application.AskToUpdateLinks = False

            Set myFolder = fso.GetFolder(sPath)

            For Each mySubFolder In myFolder.SubFolders

                Call repeatTrackingProcess(mySubFolder.Path)
                Recurse = Recurse(mySubFolder.Path)

            Next

 End Function

 'Repeat Function for multiple Files　Function repeatTrackingProcess(ByVal s As String)

    Dim fso As New FileSystemObject
    Dim myFolder As Folder
    Dim myFile As File
    Dim mySubFolder As Folder
    Dim wbk As Workbook
    Dim sFilename As String
    Dim erow
    Dim sPath As String
    Dim sht As Worksheet
    Dim LastRow As Long
    Dim LastColumn As Long
    Dim StartCell As Range
    Dim wsheetRange As Range
    Application.DisplayAlerts = False
    Application.AskToUpdateLinks = False

    Set mySubFolder = fso.GetFolder(s)
    sPath = (mySubFolder & "\")
    sFilename = Dir(sPath & "*.xlsm")

        Do While Len(sFilename) > 0
        If sFilename = "MasterTracker Projections.xlsm" Then
        Exit Do
        End If

        Set wbk = Workbooks.Open(sPath & sFilename)

        'Setting Last Saved Date in cell B41

        Range("A17:L17").Copy
        wbk.Close

        erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

        'Pasting values from individual excel files into Master
        ActiveSheet.Paste Destination:=Worksheets("Summary").Range(Cells(erow, 1), Cells(erow, 12))
        Columns("A:L").Select
        Selection.EntireColumn.AutoFit

        sFilename = Dir
        Loop

 End Function

 どうぞよろしくお願いいたします。

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

 とりあえず、
 'Repeat Function for multiple Files　Function repeatTrackingProcess(ByVal s As String)
 となってしまってますので、Function以降を改行して次のようにしてください。

 'Repeat Function for multiple Files
 Function repeatTrackingProcess(ByVal s As String)

 あと、…、サンプルデータを示さないと、こちらで再現できません。ｺｰﾄﾞを見る気になりません。

（!!!） 2017/02/23(木) 02:56

 早速のご返信ありがとうございます。肝心のデータですよね、大変失礼しました。

 A      B       C               D               E               F               G                       H               I                      J               K               L      
 Dept	Text	Svc Amend Bud	Svc Proj Bal	Opr Amend Bud	Opr Proj Bal	Total Amend Budget	Total Proj Bal	Filled Full-time	Vac Full-Time	Temp Pos	Filled Part-Time
 COM    TtlExp   1000000        150000          330000          380000          245000                  350000           160                    30              0               3
   .
   .
   .
 POL    TtlExp   1300000        180000          300000          350000          150000                  500000           280                    50              8               15

 元データの複数ブックのA17~L17に同じ形のデータがあり、それをコピー先にまとめるようになっています。
 各ブックから一行抽出なので、ブック分（20から30）の行数ができるはずなのです。
 これでわかりますでしょうか？よろしくお願いします。

（のんさびぃ） 2017/02/23(木) 03:36

 質問テーマの前に。

 フォルダからブックをピックアップするところで、

        If (fileName = "MasterTracker Projections.xlsm") Then
            Exit Do
        End If

 こんなところがありますね。

 おそらく、DIRで取り出されたブックが、このマクロブックなら対象外にするという意図でしょうけど、
 Exit Do ですから、このブックが見つかれば、それで、ループが終わり、Call Recurse(Path)　に行ってしまいます。

 いいのですか？

 それと、ブックが、自分自身かどうかを判定しているなら、ブック名をきくのは、将来ブック名が変更になった際に
 問題が出てきます。

 If fileName = ThisWorkbook.Name Then としておくのが常道です。

 今回の場合は　自ブックなら処理せずスキップですから

 Do While Len(sFilename) > 0

    If fileName <> Thisworkbook.Name Then
        ファイルを開いて処理して閉じ、コピーしてペーストするAutoFitまでの現行コード
    End If

    fileName = Dir

 Loop

 こんな構成になるかと。

 で、質問のテーマですが、コメントをするために、シートの構成を教えてください。

 updateTrackingSheet　が参照しているシートが３つあります。

 １．まず、フォルダから抽出したブックを開いたときに「たまたま」アクティブになっているシート。
 　　もし、複数シートがあるブックなら、どのシートが対象になるかわからない、あぶなっかしいコードですが
 　　Range("A17:L17").Copy　ここで参照しています。

 ２．次に、転記すべき行番号を取得する目的のコードだと思いますが
     erow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
 　（同じものが２行書かれているのは１行消し忘れ？）

 　　フォルダから取り出して開いたブックを閉じた後の実行ですから、おそらく、Sheet1 は　マクロブックのシートだと
 　　思いますが、Sheet1 という指定、ちゃんと理解してお使いですよね？
 　　これは　シート名　ではなく、シートのCodeName(オブジェクト名）です。
 　　ＶＢＥ画面の左上のプロジェクトエクスプローラを見たときに

 　　Sheet1(xxxx)
 　　Sheet2(yyyy)

 　　となっている左側がCodeName です。右の　かっこの中はシート名です。

 　　いずれにしても、この　CodeNmae が Sheet1 というシートの A列データ最終セルの次のセルの行番号を取得しています。

 ３．実際にペーストするシート。

 　　ActiveSheet.Paste Destination:=Worksheets("Summary").Range(Cells(erow, 1), Cells(erow, 12))

 　　SHeet1 の状態によって取得した erow を使って "Summary" というシート名のシートにペーストしています。
 　　この　"Summary" が Sheet1 と同じならいいのですが、そうなんですか？
 　　また　同じなら、２．の取得コードも　シート名 "Summary" を使うべきです。（ないしは、３．のコードも SHeet1 を使う）

 ★もし　Sheet1 と　"Summary" が　違うシートであれば、すべてが "Summary" シートの同じ行に上書きされてしまう
 　こういうコードになっていますね。

（ β） 2017/02/23(木) 08:16

 一番初めに書いたのですが、長年受け継がれて使われているもので、途中で誰かが何か
 （特にシート名など）を変えたりしているのかなどまったく不明でして、すみません・・・

 しかもシート構成の説明まで抜けているとは、本当に申し訳ありません。

 このマクロが書かれている文書がMaster.xlsmで、"Summary" "Sheet2" "Sheet3"の3シートがあり、"Summary"以外はブランクです。
 Master.xlsmの保存されているフォルダ内にサブフォルダ（フォルダ名はTrack）があり、その中に現在23ブック入っていて、
 それぞれ複数シートある（数や名前はバラバラ）のですが、全ブックに共通して"Summary"というシートがあり、
 そのSummaryシートのA17:L17が抽出されるべきデータです。
 つまり元データのほうも"Summary"シートで、ペースト先も"Summary"シートとなっています。

 確かに、βさんのご指摘通り、たまたまアクティブになっているシートのデータが返されているらしき現象もありました。
 引き続きどうぞよろしくお願いいたします。

（のんさびぃ） 2017/02/23(木) 13:26

 想像しながら書いているところが少なくないので、不具合あれば指摘願います。

 ・サブフォルダからの抽出のための再帰処理ですが、同じ処理のプロシジャの２段構えになっていましたので
 　ふつうのFSOによる再帰処理の記述にしてあります。
 ・MasterTracker Projections.xlsm　の除外が必要なのかどうかわかりませんけど、残してあります。
 ・対象ブックの判定を　If LCase(tmp(UBound(tmp))) Like "xls*" Then　にしてあります。
 　つまり、xlsxブックでも抽出するというロジックにしています。
 　そうではなく xlsm　ブックのみ対象ということなら、これを　If LCase(tmp(UBound(tmp))) = "xlsm" Then
　 に変えてください。

 Sub Sample()
    Dim fso As FileSystemObject
    Dim sht As Worksheet

    Application.AskToUpdateLinks = False
    Application.ScreenUpdating = False

    Set sht = ThisWorkbook.Sheets("Summary")
    Set fso = New FileSystemObject

    Call RecurseX(sht, fso.GetFolder(Application.ActiveWorkbook.path & "\"))

    sht.Columns("A:L").AutoFit

    Application.ScreenUpdating = True

    'Msg on Completion
    MsgBox "Tracking Sheet Updated Successfully"

 End Sub

 Private Sub RecurseX(sht As Worksheet, fd As Folder)
    Dim ff As File
    Dim sd As Folder
    Dim erow As Long
    Dim wbk As Workbook
    Dim shf As Worksheet
    Dim tmp As Variant

    For Each ff In fd.Files
        If ff.Name <> "MasterTracker Projections.xlsm" Then
            tmp = Split(ff.Name, ".")
            If LCase(tmp(UBound(tmp))) Like "xls*" Then
                If Not ff.Name Like "*" & ThisWorkbook.Name Then
                    Set wbk = Workbooks.Open(ff.path)
                    On Error Resume Next
                    Set shf = wbk.Worksheets("Summary")
                    On Error GoTo 0
                    If shf Is Nothing Then
                        MsgBox wbk.Name & "には、Summaryシートがないので抽出をスキップします"
                    Else
                        shf.Range("A17:L17").Copy sht.Range("A" & Rows.Count).End(xlUp).Offset(1)
                    End If
                    wbk.Close False
                End If
            End If
        End If
    Next

    For Each sd In fd.SubFolders
        Call RecurseX(sht, sd)
    Next

 End Sub

（ β） 2017/02/23(木) 16:34

 βさん、どうもありがとうございました。
 上記コードを試したところ、抽出されたのは５行だけで、値がすべて=#REF!という表示になりました。
 元データにも問題があるのですかね？
 引き続き何かわかりましたら、よろしくお願いします。
（のんさびぃ） 2017/02/23(木) 22:07

 >抽出されたのは５行だけで、値がすべて=#REF!という表示になりました

 コメントしましたように、想像で書いているところがありますから、要件を誤解している公算は低くないですが

 ・実際には対象のブックが、もっとたくさんあるということですか？
 ・なによりも =#REF 。抽出元ブックの　Summaryシートの A17:L17 ですけど、ここには数式が入っているのですか？
 　元々のそちらのコードでコピペをしていたのでアップしたコードでもコピペ方式にしました。
 　なので、元データが数式ならコピペされたものも数式になります。
 　具体的には、どんな数式が書かれていたのですか？
 ・で、数式のまま持ってくるというのは、正しいのですか？
 　それとも、値に変換して持ってくるべきですか？
 ・転記元ブックのSummaryシートの A17 ですけど、必ず値が入っているのですか？
 　それとも、ブックによっては、A17が空白というものもありますか？
 　アップしたコードは、A17に必ず何かしらの値があるということを前提にしています。
 　もし、A17 が空白ありうるということなら、転記済みの行の次の行ではなく、取り込み済みの行に上書きされる可能性もありますので
 　本来 10行なのに 見た目、5行しか取り込めていないという状況はありえます。
 　これを回避する手立てはありますので、A17 がどうなっているかを教えてください。

（ β） 2017/02/23(木) 22:25

 対象ブックは現在23あるので、23行抽出されるべきなのですが。
 ご推測の通り、A17が空白になっているブックがありました。
 元データのA17:L17は合計値なので数式が入っていました、SUMです。値に変換したいです。
 大変ご迷惑おかけしていますが、引き続きよろしくお願いいたします。

（のんさびぃ） 2017/02/23(木) 23:26

 それでは、RecurseX のみ　以下でリバイスして試してください。 Sample はアップ済みのままでＯＫです。

 Private Sub RecurseX(sht As Worksheet, fd As Folder)
    Dim ff As File
    Dim sd As Folder
    Dim erow As Long
    Dim wbk As Workbook
    Dim shf As Worksheet
    Dim tmp As Variant

    For Each ff In fd.Files
        If ff.Name <> "MasterTracker Projections.xlsm" Then
            tmp = Split(ff.Name, ".")
            If LCase(tmp(UBound(tmp))) = "xlsm" Then
                If Not ff.Name Like "*" & ThisWorkbook.Name Then
                    Set wbk = Workbooks.Open(ff.path)
                    On Error Resume Next
                    Set shf = wbk.Worksheets("Summary")
                    On Error GoTo 0
                    If shf Is Nothing Then
                        MsgBox wbk.Name & "には、Summaryシートがないので抽出をスキップします"
                    Else
                        erow = sht.Range("A1").CurrentRegion.Rows.Count + 1
                        With shf.Range("A17:L17")
                            sht.Range("A" & erow).Resize(, .Columns.Count).Value = .Value
                        End With
                    End If
                    wbk.Close False
                End If
            End If
        End If
    Next

    For Each sd In fd.SubFolders
        Call RecurseX(sht, sd)
    Next

 End Sub

（ β） 2017/02/24(金) 09:07

 もし、上記でＯＫなら、あくまで参考コードとして。

 RecurseX を以下にすると、参照元ブックを開かず、外部参照式での抽出で処理が可能です。
 ただし、対象分のすべてに Summary というシートがないと不具合が発生しますから
 不安は不安ですが、処理効率は圧倒的にこちらが優れています。。

 Private Sub RecurseX(sht As Worksheet, fd As Folder)
    Dim ff As File
    Dim sd As Folder
    Dim erow As Long
    Dim tmp As Variant
    Dim frm As String

    For Each ff In fd.Files
        If ff.Name <> "MasterTracker Projections.xlsm" Then
            tmp = Split(ff.Name, ".")
            If LCase(tmp(UBound(tmp))) = "xlsm" Then
                If Not ff.Name Like "*" & ThisWorkbook.Name Then
                    frm = "'" & fd.path & "\[" & ff.Name & "]Summary'!A17"
                    erow = sht.Range("A1").CurrentRegion.Rows.Count + 1
                    With sht.Range("A" & erow).Resize(, 12)
                        .Formula = "=IF(" & frm & "="""",""""," & frm & ")"
                        .Value = .Value
                    End With
                End If
            End If
        End If
    Next

    For Each sd In fd.SubFolders
        Call RecurseX(sht, sd)
    Next

 End Sub

（ β） 2017/02/24(金) 09:41

 βさん、大変お世話になっております。
 別のコードまでご用意いただき、感謝の気持ちでいっぱいです。
 こちら時差があって現在夜なのですが、明朝出社次第試して結果をご報告させていただきます。
 まずはお礼まで。

（のんさびぃ） 2017/02/24(金) 11:05

 βさん、今試してみましたが、どちらも完璧にデータが抽出されました。
 元ブックを開かないほうのコードは、おっしゃる通り一瞬で処理されました。
 ぜひこちらを使わせていただきます。
 親身になって対応していただき、βさんには心より感謝申し上げます。
 本当に本当にありがとうございました。
（のんさびぃ） 2017/02/24(金) 21:49

コメント返信：

[ 一覧(最新更新順) ]

[[20170223003629]] 『複数ブックのデータをまとめるマクロのデータが重』（のんさびぃ） ページの最後に飛ぶ

[[20170223003629]]　『複数ブックのデータをまとめるマクロのデータが重』（のんさびぃ）　ページの最後に飛ぶ