Excel VBA質問箱 IV

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

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


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

818 / 76735

←次へ　｜　前へ→


	【81579】Re:セルを分割し別ブックに保存する

［名前なし］ - 20/12/20(日) 11:13 -


	引用なし

	パスワード

Sub tes()

Dim objFs As Object
Dim InPath As String, OutPath As String
Dim InFs As Variant, InBook As Workbook, InSh As Worksheet
Dim OutBook As Workbook, OutSh As Worksheet, OutFname As String
Dim Flag As Boolean, Cnt As Integer
Dim Dic As Object, DicVari As Variant
Dim FnamEx　As String, FsEx As String, DirFn As String
　　　　
　　　　
''''
InPath = "D:\IN"
OutPath = "D:\OUT"
FnamEx = ".xlsx"

''''
InPath = InPath & "\"
OutPath = OutPath & "\"

''''

Dim app As New Excel.Application
app.Visible = False
With app
　　'
　　If Dir(OutPath, vbDirectory) = "" Then
　　　　MkDir OutPath
　　End If
　　'
　　Set Dic = CreateObject("Scripting.Dictionary")

　　Set objFs = CreateObject("Scripting.FileSystemObject")
　　For Each InFs In objFs.GetFolder(InPath).Files
　　　　FsEx = "." & LCase(objFs.GetExtensionName(InFs.Name))
　　　　If FsEx = FnamEx Then
　　　　　　Debug.Print InFs.Name
　　　　　　Set InBook = .Workbooks.Open(InPath & InFs.Name)
　　　　　　
　　　　　　For Each InSh In InBook.Sheets
　　　　　　　　OutFname = InSh.Range("D4").Text & FnamEx
　　　　　　　　DirFn = OutPath & OutFname
　　　　　　　　If Dic.Exists(OutFname) = False Then
　　　　　　　　　　Dic.Add OutFname, 0
　　　　　　　　　　If Dir(DirFn) <> "" Then
　　　　　　　　　　　　Set OutBook = .Workbooks.Open(DirFn)
　　　　　　　　　　　　
　　　　　　　　　　Else
　　　　　　　　　　　　Set OutBook = .Workbooks.Add
　　　　　　　　　　　　OutBook.SaveAs (DirFn)
　　　　　　　　　　　
　　　　　　　　　　End If
　　　　　　　　Else
　　　　　　　　　　'Dic登録済み。Book開いている。
　　　　　　　　　　Set OutBook = .Workbooks(OutFname)
　　　　　　　　　
　　　　　　　　End If
　　　　　　　　'シートコピー
　　　　　　　　Cnt = OutBook.Sheets.Count
　　　　　　　　InSh.Copy After:=OutBook.Sheets(Cnt)
　　　　　　　　'シートプロテクト
　　　　　　　　Cnt = Cnt + 1
　　　　　　　　OutBook.Sheets(Cnt).Protect
　　　　　　　　
　　　　　　　　Set InSh = Nothing
　　　　　　　　Set OutBook = Nothing
　　　　　　Next
　　　　　　
　　　　　　InBook.Close False
　　　　　　Set InBook = Nothing
　　　　End If
　　Next
'開いたOutBookを閉じる
　　For Each DicVari In Dic
　　　　OutFname = DicVari
　　　　.Workbooks(OutFname).Save
　　　　.Workbooks(OutFname).Close
　　Next
End With

app.Quit
Set app = Nothing

End Sub

0 hits

▼

【81577】セルを分割し別ブックに保存する あお 20/12/16(水) 22:36