| |
▼ビータン さん：
こんばんわ 247bです。
こんな感じですか？
変数は宣言しましょう。
インデントを使った方がプログラムが見やすくなります。
Scriptingコンポーネントというのを使っています。
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
sh.Cells(cnt, 1).Value = ws.Cells(1, 1).Value
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
' Dim i As Long
'
' With ActiveCell
' For i = .Row + 1 To Rows.Count
' If Not Rows(i).Hidden Then
' Cells(i, .Column).Select
' Exit For
' End If
' Next
' End With
' Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
' :=False, Transpose:=False
'
' aBN.Save
' aBN.Close
' End If
' Filename = Dir()
' Loop
'Application.ScreenUpdating = False
'
'
'End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 10/9/5(日) 12:37 -
