| |
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
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
