結構悩み、苦しみましたが自分が望んでいるVBAが完成しましたZE
以下VBAソース
Sub SheetCopy3() 'ユーザーが指定したディレクトリ内にあるxlsデータ全てにシート分割処理を行う
Dim wb As Workbook
Dim strFnm As String
Dim strDir As String
Dim strDir2 As String
Dim i As Integer
Dim AWN As String
Dim ShtCnt As Integer
Dim ShellApp As Object
Dim SaveFolder As Object
Dim TargetFolder As Object
'処理をするディレクトリを決める
Set ShellApp = CreateObject("Shell.Application")
Set TargetFolder = ShellApp.BrowseForFolder(0, "処理を行うフォルダを選択してください。", 1)
If TargetFolder Is Nothing Then Exit Sub
'エラーチェック
If ThisWorkbook.Path = TargetFolder.items.Item.Path Then
MsgBox "このツールと同じフォルダにあるデータは処理できません。"
Exit Sub
End If
'保存するディレクトリを決める
Set SaveFolder = ShellApp.BrowseForFolder(0, "保存先フォルダを選択してください。", 1)
If SaveFolder Is Nothing Then Exit Sub
'処理を行うディレクトリ
strDir = TargetFolder.items.Item.Path
strDir2 = SaveFolder.items.Item.Path
'処理を行う対象データ
strFnm = Dir(strDir & "\*.xls")
'警告ウインドウ非表示
Application.ScreenUpdating = False
'処理開始
Do Until strFnm = ""
Set wb = Workbooks.Open(strDir & "\" & strFnm)
'処理内容
ShtCnt = wb.Worksheets.Count
'MsgBox ShtCnt
AWN = Left(wb.Name, Len(wb.Name) - 4)
'MsgBox AWN
i = 1
ChDir (strDir2)
Do
wb.Worksheets(i).Activate
wb.Worksheets(i).Copy
ActiveWorkbook.Close savechanges:=True _
, Filename:=AWN & "_" & ActiveSheet.Name & ".xls"
i = i + 1
'MsgBox "通過確認"
Loop Until i > ShtCnt
wb.Close False
strFnm = Dir() '次のファイル名
Loop
Application.ScreenUpdating = True
End Sub
__________________________
作ってて楽しかったわ＾＾
参考になったページは前の日記で紹介したもの＾＾
結構試行錯誤もしたし、エラーがでない不具合とかもでて苦しんだわ(￣Д￣;;
しまし不屈の闘士と発想の勝利とでも言うべきか。完成するとかなり嬉しいわｗ
後はこちらを色々と利用するまでですわ。偶然このページを見つけた方もコピペしてもらってかまわないけど自己責任で。
さて、これでもまだひとつ出来ただけにすぎないからね。
後思ってるマクロもあるけどそれは明日にしますかね～。
