[[20150414002202]] 『フォルダ内にある全ファイル名を別のファイルに呼』(ちぃちゃん) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『フォルダ内にある全ファイル名を別のファイルに呼び出したい』(ちぃちゃん)

 こんばんは。

 デスクトップにある「ABC」というフォルダ内に複数のエクセルファイルがあります。
 1504_11-150011-011-01-1
 1504_11-150123-012-11-1
 1504_11-150033-015-00-1
 1504_11-150159-012-01-2 といった感じのファイルが14〜15個あります。

 集計.xlsmのコマンドボタンをクリックした時に、集計ファイルのA列に
 上記「ABC」フォルダに入っている全エクセルファイルのファイル名を、
 B列に各ファイルのC5セルに入力されている値を表示させたいと思っていますが
 やり方を教えて頂けないでしょうか。

 宜しくお願いします。

< 使用 Excel:Excel2007、使用 OS:Windows7 >


 別の板ですが、1つのブックからそのシート上の特定セルの値をマクロブックに取り込む案件があって
 私からは【ブックを開いて取り込む】、また別の回答者さんから【ブックを開かずに取り込む】回答があります。

 これを利用して

 ・1つのブックを開いているところを、フォルダ内のブックをループで取り出して開く
 ・取り込んだものを定位置ではなく、行を変えて転記していく。

 この制御を追加することになります。

http://excelfactory.net/excelboard/excelvba/excel.cgi?mode=all&namber=169223&rev=0

 以下に、開かないタイプと開くタイプを。なお、開かないタイプは、処理は軽いというか早いのですが
 対象ブックのシート名を "Sheet1" と固定しています。
 ブックにより名前が異なる場合は使えません。

 Sub TestNonOpen()
    Dim FullPathName As String
    Dim i As Long, j As Long
    Dim s As String
    Dim fPath As String
    Dim fName As String
    Dim tSh As Worksheet
    Dim x As Long

    fPath = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\ABC\"
    Set tSh = ThisWorkbook.Sheets(1)    '転記シート
    x = 1                               '転記開始行

    fName = Dir(fPath & "*.xlsx")

    Do While fName <> ""
        FullPathName = fPath & fName
        i = InStrRev(FullPathName, "\")
        j = Len(FullPathName) - i
        ' 変数 s に、対象ブックの "Sheet1!対象セル" までの参照式を格納
        s = "'" & Left(FullPathName, i) & "[" & _
            Right(FullPathName, j) & "]" & "Sheet1" & "'!R5C3"
        tSh.Cells(x, "A").Value = fName
        tSh.Cells(x, "B").Value = ExecuteExcel4Macro(s)
        fName = Dir()
        x = x + 1
    Loop

 End Sub

 Sub TestOpen()
    Dim fPath As String
    Dim fName As String
    Dim tSh As Worksheet
    Dim fSh As Worksheet
    Dim x As Long

    Application.ScreenUpdating = False

    fPath = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\ABC\"
    Set tSh = ThisWorkbook.Sheets(1)    '転記シート
    x = 1                               '転記開始行

    fName = Dir(fPath & "*.xlsx")

    Do While fName <> ""
        Set fSh = Workbooks.Open(fPath & fName).Sheets(1)
        tSh.Cells(x, "A").Value = fName
        tSh.Cells(x, "B").Value = fSh.Range("C5").Value
        fSh.Parent.Close False
        fName = Dir()
        x = x + 1
    Loop

 End Sub

(β) 2015/04/14(火) 06:52


 β様 こんばんは。
 返信ありがとうございます。

 今回は、対象ブックのシート名を "Sheet1" と固定していても
 問題ないので、処理の早い方を使用させて頂いたところ、理想
 通りの事が出来ましたのでこちらを使用させて頂きたいと思います。

 毎日の作業で時間が削減出来てすごい助かりました。
 ありがとうございました。

(ちぃちゃん) 2015/04/15(水) 00:19


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.