[[20130730091419]]　『異なるフォルダーからのデータ集約方法』（おーちゃん）　ページの最後に飛ぶ

『異なるフォルダーからのデータ集約方法』（おーちゃん）
以下の通り、データを集約するマクロを教えて下さい。よろしくお願いします。

      c:\matome に保存されているsum.xlsの sheet2に
      c:\matome\energyに保存されているcsv形式とexcel形式の複数のブックを集約
      する。
      （※ブック数は毎週増えていく）

 同じフォルダー上にあるブックの集約マクロは過去ログを参考にしできたのですが、
 他のフォルダーにあるブックの集約はうまくいきません。
 また、下記マクロはcsv形式のみが集約されますが、excel形式を追加することも
 できません。

＜参考：同一フォルダーのデータ集約＞

 sub データ集約()
    'このブックと同一フォルダ内のブックの、１シート目の4行目以下を、
    '新規ブックの１シートにまとめる
    Dim sBook As Workbook
    Dim dBook As Workbook
    Dim Fpath As String
    Dim Fname As String
    Dim rr As Range
    Dim Dst As Range

    Fpath = ThisWorkbook.Path & "\"
    Fname = Dir(Fpath & "*.csv")

    Application.ScreenUpdating = False

    Do Until Fname = ""
        If LCase(Fname) = LCase(ThisWorkbook.Name) Then
        Else
            If Dst Is Nothing Then
                Set Dst = ThisWorkbook.Worksheets(2).Range("C2")  '既存ブックの2シート目の2行目以降に貼り付け

            End If
            Set sBook = Workbooks.Open(Fpath & Fname)
            Set rr = sBook.Worksheets(1).UsedRange '1シート目
            Set rr = Intersect(rr, rr.Offset(3))  '4行目以下をコピー
            rr.Copy Dst
            Set Dst = Dst.Offset(rr.Rows.Count)
            sBook.Close False
        End If
        Fname = Dir()
    Loop

    Application.ScreenUpdating = True
    MsgBox "Completed！"
   End Sub

 上記のマクロを
 　　　　：
 　　　　：
    Fname = Dir(ThisWorkbook.Path & "\energy\*.*")
    Application.ScreenUpdating = False
    Do Until Fname = ""
        If Not LCase(Fname) = LCase(ThisWorkbook.Name) _
           And ( InStr( FName, ".csv" ) > 0 Or InStr( FName, ".xls" ) > 0 ) Then
 　　　　：
 　　　　：

 に変更でどうでしょうか。
 (Mook)

Mook様

早速ご回答頂きありがとうございました。
以下の通りマクロを変更してみましたが、動作しません。
何か間違っているのでしょうか？ご教授願いますよう宜しくお願いいたします。

Sub データ集約２()

    Dim sBook As Workbook
    Dim dBook As Workbook
    Dim Fpath As String
    Dim Fname As String
    Dim rr As Range
    Dim Dst As Range

    Fpath = ThisWorkbook.Path & "\"
    Fname = Dir(ThisWorkbook.Path & "\energy\*.*")
    Application.ScreenUpdating = False
    Do Until Fname = ""
        If Not LCase(Fname) = LCase(ThisWorkbook.Name) _
           And (InStr(Fname, ".csv") > 0 Or InStr(Fname, ".xls") > 0) Then

        Else
            If Dst Is Nothing Then
                Set Dst = ThisWorkbook.Worksheets(3).Range("A2")  '既存ブックの3シート目の2行目以降に貼り付け

            End If
            Set sBook = Workbooks.Open(Fpath & Fname)
            Set rr = sBook.Worksheets(1).UsedRange '1シート目
            Set rr = Intersect(rr, rr.Offset(7))  '8行目以下をコピー
            rr.Copy Dst
            Set Dst = Dst.Offset(rr.Rows.Count)
            sBook.Close False

        End If
        Fname = Dir()
    Loop

    Application.ScreenUpdating = True
    MsgBox "Completed！"
End Sub

 Else は削ってください。
 (Mook)

Ｍｏｏｋ様

Elseは削除しましたが、以下のエラーメッセージが表示されてしまいます。
デバックをみると「Set sBook = Workbooks.Open(Fpath & Fname)」の箇所がひっかかっているようです。
Fpathが悪さしているんでしょうか？

実行時エラー’1004’：
’(ファイル名).csv’が見つかりません。ファイル名及びファイルの保存場所が正しいか確認してください。

 そこも変更が必要ですね。
    Fpath = ThisWorkbook.Path & "\"
 は
    Fpath = ThisWorkbook.Path & "\energy\"
 にしておいてください。
 (Mook)

Ｍｏｏｋさん

解決しました。
いろいろと教えていただきましてありがとうございました。

コメント返信：

[ 一覧(最新更新順) ]

[[20130730091419]] 『異なるフォルダーからのデータ集約方法』（おーちゃん） ページの最後に飛ぶ

[[20130730091419]]　『異なるフォルダーからのデータ集約方法』（おーちゃん）　ページの最後に飛ぶ