|
▼ぴょんきち さん:
おはようございます。
ご参考までに、新規ブックのA列にブック名、B列に抽出ブックのA1の値、B列に抽出ブックのC1の値を
セットするコードを2つ。
Sample1Aは実際にブックを開いて参照します。
参照するシートは開いたブックの一番左にあるシートとしています。
Sample1Bはブックを開かずにセルの値を転記します。
ただし、シート名がわかっていることが前提。サンプルでは"Sheet1"としています。
Option Explicit
Sub Sample1A()
Dim myPath As String
Dim myFile As String
Dim c As Range
myPath = Get_Folder
If myPath = "" Then Exit Sub
Application.ScreenUpdating = False
Workbooks.Add
Cells.ClearContents
Range("A1:C1").Value = Array("ファイル名", "A1", "C1") 'タイトル
Set c = Range("A2") '編集開始位置
myFile = Dir(myPath & "\*.xls") 'エクセルブックのみ抽出
Do While myFile <> ""
If myFile <> ThisWorkbook.Name Then '念のため
c.Value = myFile
Workbooks.Open myPath & "\" & myFile
c.Offset(, 1).Value = Worksheets(1).Range("A1").Value
c.Offset(, 2).Value = Worksheets(1).Range("C1").Value
ActiveWorkbook.Close savechanges:=False
Set c = c.Offset(1)
End If
myFile = Dir()
Loop
Columns("A:C").AutoFit
Set c = Nothing
Application.ScreenUpdating = True
End Sub
Sub Sample1B()
Dim myPath As String
Dim myFile As String
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
Cells.ClearContents
Range("A1:C1").Value = Array("ファイル名", "A1", "C1") 'タイトル
Set c = Range("A2") '編集開始位置
myFile = Dir(myPath & "\*.xls") 'エクセルブックのみ抽出
Do While myFile <> ""
If myFile <> ThisWorkbook.Name Then '念のため
c.Value = myFile
linkStr = "='" & myPath & "\[" & myFile & "]" & 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)
End If
myFile = Dir()
Loop
Columns("A:C").AutoFit
Set c = Nothing
Application.ScreenUpdating = True
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
|
|