[[20140112193605]]　『2010ではApplication.FileSearchは対応していない』（MIKOTO）　ページの最後に飛ぶ

『2010ではApplication.FileSearchは対応していない』（MIKOTO）

 同じ形式の(複数)ファイルを、指定ファイルにコピーしています。
 2010ではApplication.FileSearchが対応しておらず
 FileSystemObjectまたは、Dir関数にて対応できるとの事ですが
 どのように書き換えればよいかご教授お願いできませんでしょうか？
 よろしくお願いします。

 dr = Worksheets("CTL").Cells(4, 5).Value
    ChDir dr

    Set fs = Application.FileSearch
    With fs
        .LookIn = dr
        .Filename = "*.xls"
            If .Execute > 0 Then
                MsgBox (.FoundFiles.Count & " 個のファイルが見つかりました。")

                For i = 1 To .FoundFiles.Count
                    Workbooks.Open Filename:=.FoundFiles(i)
                    filename1 = .FoundFiles(i)
                    filename2 = Mid(filename1, Len(dr) + 2, Len(filename1) - Len(dr))

                    Sheets("OUT").Select
                    Range("DATA").Select
                    Range("DATA").Activate
                    Selection.Copy

                    Windows("KANRIR2.xls").Activate
                    Sheets("DATAIN").Select
                    Range("A1").Select
                    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                        :=False, Transpose:=False

                    Call JUMP1
                    Call JUMP2
                    Call JUMP3

                Workbooks(filename2).Close SaveChanges:=False

                Next i
            Else
                MsgBox "検索条件を満たすファイルはありません。"
            End If
    End With

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

 このあたりはご覧になったでしょうか。
http://officetanaka.net/excel/vba/tips/tips36.htm

 やり方はいろいろあると思いますが、一例まで。
 Sub Sample()
    dr = Worksheets("CTL").Cells(4, 5).Value
    Set objDic = CreateObject("Scripting.Dictionary")
    file = Dir(dr & "\*.xls")
    Do While file <> ""
        objDic(dr & "\" & file) = True
        file = Dir()
    Loop

    If objDic.Count = 0 Then
        MsgBox "検索条件を満たすファイルはありません。"
    Else
        MsgBox objDic.Count & " 個のファイルが見つかりました。"
        For Each file In objDic.keys
            With Workbooks.Open(file)
                With .Sheets("OUT").Range("DATA")
                    Workbook("KANRIR2.xls").Sheets("DATAIN").Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
                End With
                .Close SaveChanges:=False
            End With
            Call JUMP1
            Call JUMP2
            Call JUMP3
        Next
    End If
 End Sub

 最初のファイル数表示をしなくて良いなら Dictionary は使用する必要はありません。
（Mook） 2014/01/12(日) 21:44

 Mookさんありがとうございました。
 サンプルページを参考に頑張ってみましたが、なかなかうまくできず
 質問させていただきました。　
 >Workbook("KANRIR2.xls").Sheets("DATAIN").Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
 WorkbookをWorkbooksに修正し　正常に処理できました。
 　
（MIKOTO） 2014/01/12(日) 23:00

コメント返信：

[ 一覧(最新更新順) ]

[[20140112193605]] 『2010ではApplication.FileSearchは対応していない』（MIKOTO） ページの最後に飛ぶ

[[20140112193605]]　『2010ではApplication.FileSearchは対応していない』（MIKOTO）　ページの最後に飛ぶ