| |
▼ぴょんきち さん：
Sample4としてアップしますね。
(GetBooksプロシジャも、ちょっと直してあります)
Option Explicit
Sub Sample4()
Dim myPath As String
Dim myFso As Object
Dim myPool As Collection
Dim myFold As Object
Dim myData As Variant
Dim c As Range
Dim refShn As String
Dim linkStr As String
myPath = Get_Folder
If myPath = "" Then Exit Sub
Application.ScreenUpdating = False
refShn = "Sheet1" '参照するシート名。適宜変更。
Workbooks.Add
Range("A1:C1").Value = Array("ファイル名", "A1", "C1")
Set c = Range("A2") '編集開始位置
Set myFso = CreateObject("Scripting.FileSystemObject")
Set myFold = myFso.getfolder(myPath)
Set myPool = New Collection
Call getBooks(myFold, myPool) '中でサブフォルダ内も再帰で検索
For Each myData In myPool
c.Value = myData(0)
linkStr = "='" & myData(1) & "\[" & myData(0) & "]" & refShn & "'!"
c.Offset(, 1).Value = linkStr & "A1"
c.Offset(, 2).Value = linkStr & "C1"
c.Offset(, 1).Resize(, 2).Value = c.Offset(, 1).Resize(, 2).Value
Set c = c.Offset(1)
Next
Set myFso = Nothing
Set myFold = Nothing
Set myPool = Nothing
Set c = Nothing
Application.ScreenUpdating = True
End Sub
Private Sub getBooks(fold As Object, myPool As Collection)
Dim myfile As Object
Dim myFold As Object
For Each myfile In fold.Files
If StrConv(Right(myfile.Name, 4), vbLowerCase) = ".xls" And _
myfile.Name <> ThisWorkbook.Name Then
myPool.Add Array(myfile.Name, myfile.ParentFolder)
End If
Next
For Each myFold In fold.subfolders
Call getBooks(myFold, myPool) '再帰によるサブフォルダ検索
Next
End Sub
Private Function Get_Folder() As String
Dim ffff As Object
Dim WSH As Object
Set WSH = CreateObject("Shell.Application")
Set ffff = WSH.BrowseForFolder(&H0, "フォルダを選択してください", &H1 + &H10)
If ffff Is Nothing Then
Get_Folder = ""
Else
Get_Folder = ffff.Items.Item.Path
End If
Set ffff = Nothing
Set WSH = Nothing
End Function
|
|
UO3
- 11/4/6(水) 18:00 -
