| |
▼sagfacttine さん：
とりあえずコード案をアップしておきます。
要件を誤解していたら言ってください。
Sub Sample()
Dim myFolder As String
Dim newName As String
Dim getBookName As String
Dim newBook As Workbook
Dim numSh As Long, i As Long
Dim okFlag As Boolean
Application.ScreenUpdating = False
myFolder = "C:\Documents and Settings\All Users\Documents\test" & "\"
newName = "Z.xls" '<=== 統合ブックのブック名
Set newBook = Workbooks.Add
numSh = Worksheets.Count
getBookName = Dir(myFolder & "*.xls")
Do While getBookName <> ""
With Workbooks.Open(myFolder & getBookName)
If Not IsError(Evaluate("入力シート!A1")) Then
okFlag = True
.Worksheets("入力シート").Copy after:=newBook.Worksheets(newBook.Worksheets.Count)
With newBook
.Worksheets(.Worksheets.Count).Name = getBookName & "_入力シート"
End With
Else
MsgBox getBookName & "に入力シートがありません"
End If
.Close savechanges:=False
End With
getBookName = Dir()
Loop
Application.DisplayAlerts = False
If okFlag Then
For i = 1 To numSh
newBook.Worksheets(1).Delete
Next
newBook.SaveAs myFolder & newName
MsgBox "処理が終わりました"
Else
MsgBox "フォルダに対象ブックが存在しません"
End If
newBook.Close '処理終了時に作成したブックを表示しときたい場合は、ここを削除。
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set newBook = Nothing
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
