[[20160212134630]] 『フォルダ内のエクセルファイルから指定セルの値の』(935) ページの最後に飛ぶ

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

 

『フォルダ内のエクセルファイルから指定セルの値のみ一覧にする』(935)

 フォルダ内にエクセルファイルが500個程入っています。
 内容は全て配送先のリストなんですが、sheet1のセルH5に顧客コード、H6に顧客名が入っています。
 そしてSheet2のC5〜I5までに配送先の住所等が入っています。
 配送先の住所等は1ヶ所の場合もあれば、100ヶ所の場合もあります。

 ひとつひとつファイルを開いて出荷先を確認するのが大変なので、顧客コード・顧客名・住所等情報 のみを全ファイル分一覧にしたいです。
 マクロで作成できますか?

 例:0123_顧客A.xlsm (←ファイル名)
   Sheet1  A B … H   I  
       5      0123
             6         顧客A

   Sheet2  A B  C    D   E   F    …
       5    1230000 住所1 電話1 担当者名1 …
       6    2438014  住所2 電話2 担当者名2 … 

 次のように新規ファイルに書き出したい

   A  B    C   D   E    F   …
 1 0123 顧客A 1230000 住所1 電話1 担当者名1 …
 2 0123 顧客A 2438014  住所2 電話2  担当者名2 …

 Sheet2の住所が100ヶ所(100行)の場合は、新規ファイルに書き出した時の
 AとBのセルにも100行分顧客コードと顧客名が入力されていてほしいです。

 ご教示お願いします。

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


 Sub test()
    Const cPATH = "c:\test\"
    Dim iR As Long
    Dim iMax As Long
    Dim cFile As String

    Application.ScreenUpdating = False

    iR = 1
    Cells.ClearContents

    cFile = Dir(cPATH & "????_*.xlsm")
    While cFile <> ""
        With Workbooks.Open(cPATH & cFile, False, True)
            With .Sheets("Sheet2")
                iMax = .Cells(.Rows.Count, "C").End(xlUp).Row
                .Rows("5:" & iMax).Copy Cells(iR, "A")
            End With
            Cells(iR, "A").Resize(iMax - 4, 1).Value = .Sheets("Sheet1").Range("H5")
            Cells(iR, "B").Resize(iMax - 4, 1).Value = .Sheets("Sheet1").Range("H6")
            iR = iR + iMax - 4
            .Close False
        End With
        cFile = Dir
    Wend

    Application.ScreenUpdating = True
 End Sub
(???) 2016/02/12(金) 14:37

 自分で書くなら、???さんのコードのようにブックを開いて処理しますが、遊び(?)で。
 コード内で使っている数式は、先ごろ、ブックを開かずにデータを取得するテーマで、ichinoseさん、半平太さんが使われたものを借用。

 Sub Test2()
    Dim fPath As String
    Dim fName As String
    Dim myPath As String
    Dim myRows As Long
    Dim shT As Worksheet
    Dim pos As Range
    Dim wkR As Range

    Application.ScreenUpdating = False

    Set shT = Workbooks.Add(xlWBATWorksheet).Sheets(1)
    Set pos = shT.Range("A1")                       '転記開始セル
    Set wkR = ThisWorkbook.Sheets(1).Range("A1")    'マクロブックのシートの A1,A2 を作業域として使用(対象シートのデータ最終行把握のため)
    fPath = "c:\TEST\"                              '★対象フォルダパス 実際のものに

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

    Do While fName <> ""

        myPath = "'" & fPath & "[" & fName & "]"   'Sheet2'!"

        wkR.FormulaLocal = "=IFERROR(MATCH(""""," & myPath & "Sheet2'!C:C,-1),1)"
        wkR.Offset(1).FormulaLocal = "=IFERROR(MATCH(10^17," & myPath & "SHeet2'!C:C,1),1)"
        myRows = Application.Max(wkR, wkR.Offset(1)) - 4

        pos.FormulaLocal = "=" & myPath & "Sheet1'!H5"
        pos.Offset(, 1).FormulaLocal = "=" & myPath & "Sheet1'!H6"
        pos.Offset(, 2).Resize(myRows, 7).FormulaLocal = "=" & myPath & "Sheet2'!C5"
        pos.Resize(myRows, 2).Value = pos.Resize(, 2).Value
        pos.Resize(myRows, 9).Value = pos.Resize(myRows, 9).Value

        Set pos = pos.Offset(myRows)
        fName = Dir()
    Loop

    wkR.Resize(2).ClearContents

 End Sub

(β) 2016/02/12(金) 19:37


コメント返信:

[ 一覧(最新更新順) ]


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