| |
▼ぴょんきち さん：
▼UO3 さん：
ちょっとおじゃまします。
>
>それに、今回のサブフォルダを見に行ってというところで、躓いております。
別法ですが、サブフォルダを含む指定拡張子のファイルの取得は
Dirコマンドを使うと再帰せずに一覧を得ることができます。
各Bookの参照するシート名は 「Sheet1」のように固定されていることが
リンク式埋め込み方式のポイントですね
Sub Try1()
' ------- 検索フォルダの指定
Dim objFolder As Object
Const BIF_RETURNNONLYFSDIRS = &H1 'ディレクトリのみ選択可
Const BIF_EDITBOX = &H10 'アイテム名入力用のEdit_boxを表示
Dim hWnd As Long
Dim sPath As String
hWnd = Application.hWnd
Set objFolder = _
CreateObject("Shell.Application").BrowseForFolder( _
hWnd, _
"フォルダを選択して下さい", _
BIF_RETURNNONLYFSDIRS Or BIF_EDITBOX)
If (objFolder Is Nothing) Then Exit Sub
sPath = objFolder.Self.Path & "\"
' ------- サブディレクトリを含む *.xlsファイルの検索
Dim fList
Dim i As Long
Dim n As Long
Dim tmpPath As String
Dim sCmd As String
Dim ko As Long
tmpPath = Environ$("Temp") & "\Dir.tmp"
sCmd = "DIR """ & sPath & "*.xls" & """ /b /s > """ & tmpPath & """"
With CreateObject("WScript.Shell")
ko = .Run("CMD /C " & sCmd, 7, True) 'Dirコマンド実行
End With
Dim io As Integer
Dim buf() As Byte
io = FreeFile()
Open tmpPath For Binary As io
ReDim buf(1 To LOF(io))
Get #io, , buf
Close io
Kill tmpPath
fList = Split(StrConv(buf, vbUnicode), vbCrLf) 'ファイルリストを得る
' ------- リンク式表の作成
n = UBound(fList)
Dim RefTable()
ReDim RefTable(n, 1 To 3)
RefTable(0, 1) = "ファイルパス"
RefTable(0, 2) = "A1値"
RefTable(0, 3) = "C1値"
For i = 0 To n - 1
RefTable(i + 1, 1) = fList(i)
ko = InStrRev(fList(i), "\")
sCmd = "='" & Left$(fList(i), ko) & _
"[" & Mid$(fList(i), ko + 1) & "]Sheet1'!"
RefTable(i + 1, 2) = sCmd & "A1"
RefTable(i + 1, 3) = sCmd & "C1"
Next
' ------- リンク式表を新規シートに貼り付ける
Workbooks.Add(xlWBATWorksheet).Worksheets(1) _
.Cells(1).Resize(n, 3).Value = RefTable
End Sub
|
|
kanabun
- 11/4/7(木) 0:26 -
