| |
▼ビータン さん：
こんばんわ
こんな感じでどうですか。
この版だと、
B列にファイル名を表示する。
表示シートがない場合はA列は空白になる
表示シートがあり、A1が空白の場合空白になる
という仕様になっているはずです。
Option Explicit
Dim cnt As Long
Dim sh As Worksheet
Sub Main()
'
'フォルダ内指定シートの指定セル値のコピー、入力シートに貼付
Dim fso As Object
Dim fld As Object
Dim fls As Object
Dim aBN As Workbook
Dim ws As Worksheet
Dim myAD As String
Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
Set sh = Workbooks("指定セル値参照.xls").Worksheets("入力シート")
cnt = 1
myAD = ThisWorkbook.Path & "\"
'Filename = Dir(myAD & "*.xls")
Set fld = fso.GetFolder(myAD)
'Do Until Filename = ""
For Each fls In fld.Files
If fls.Name <> "指定セル値参照.xls" Then
If UCase(fso.GetExtensionName(fls.Name)) = "XLS" Then
'Set aBN = Workbooks.Open(myAD & Filename)
'Application.ScreenUpdating = False
Set aBN = Workbooks.Open(fls.Path)
For Each ws In aBN.Worksheets
If Worksheets.Count > 1 Then
If ws.Name = " 表紙 " Then
' If Worksheets.Count > 1 Then
' Sheets(" 表紙 ").Select
' Sheets(" 表紙 ").Activate
' SelectedSheets.Range("A1").Copy
' End If
If Not IsEmpty(ws.Cells(1, 1).Value) Then
sh.Cells(cnt, 1).Value = ws.Cells(1, 1).Value
End If
sh.Cells(cnt, 2).Value = fls.Name
cnt = cnt + 1
Exit For
Else
sh.Cells(cnt, 2).Value = fls.Name
cnt = cnt + 1
Exit For
End If
End If
Next
aBN.Saved = True
aBN.Close
Set aBN = Nothing
End If
End If
Next
'Loop
Application.ScreenUpdating = True
End Sub
|
|
247b
- 10/9/5(日) 22:23 -
