Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

14622 / 76734

←次へ　｜　前へ→


	【67601】Re:個々のファイルを開かずにマクロの実行

UO3 - 10/12/17(金) 12:20 -


	引用なし

	パスワード

▼はるなさん：

Sub Sample2()
　Dim myPath As String
　Dim workWB As Workbook
　Dim fsoFile As Object
　Dim Fso As Object
　Dim xlApp As Excel.Application

　myPath = "C:\Test"　 '<== 実際のフォルダ名に
　Set xlApp = New Excel.Application
　Set Fso = CreateObject("Scripting.FileSystemObject")

　For Each fsoFile In Fso.GetFolder(myPath).Files
　　If LCase(Fso.GetExtensionName(fsoFile.Name)) = "xls" Then
　　　Set workWB = xlApp.Workbooks.Open(Filename:=myPath & "\" & fsoFile.Name)
　　　If Not IsError(xlApp.Evaluate("[" & workWB.Name & "]管理シート上期!A1")) Then
　　　　workWB.Sheets("管理シート上期").Copy After:=workWB.Sheets("管理シート上期")
　　　　With workWB.ActiveSheet
　　　　　If IsError(xlApp.Evaluate("[" & workWB.Name & "]下期!A1")) Then .Name = "下期"
　　　　　.Cells.ClearContents　 'もし内容のクリアがだめならカットしてください
　　　　End With
　　　　xlApp.DisplayAlerts = False
　　　　workWB.SaveAs myPath & "\" & workWB.Name & "_下期.xls"
　　　　workWB.Close
　　　　xlApp.DisplayAlerts = True
　　　End If
　　End If
　Next

　xlApp.Quit

　MsgBox "処理が終了しました"

End Sub

1 hits

▼

【67585】個々のファイルを開かずにマクロの実行 はるな 10/12/16(木) 17:25