| |
ブックの形式を取得して同じ形式で保存します。
Sub test()
Dim fol As String
Dim newfol As String
Dim wb As Workbook
Dim wbmei As String
Dim wsmei As String
Dim kwisaiki As String
Dim newwb As Workbook
Dim newwbpath As String
Dim ws As Worksheet
Dim wscnt As Integer
Dim wsnum As Integer
Dim i As Integer
'元フォルダ指定/ここを適宜変える
fol = "C:\Users\hoge\Desktop\aaa"
'新規フォルダパス指定/ここを適宜変える
newfol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & Format(Now, "yymmdd_hhmmss")
'新規フォルダ作成
MkDir (newfol)
'ブック一覧取得
wbmei = Dir(fol & "\*.xls*")
'既定の新規ブックのシート数取得
wsnum = Application.SheetsInNewWorkbook
'新規ブックのシート数を「1」に設定
Application.SheetsInNewWorkbook = 1
Application.ScreenUpdating = False
'ループ処理
Do While wbmei <> ""
'イベントの抑制
Application.EnableEvents = False
'元のブックを開く
Set wb = Workbooks.Open(fol & "\" & wbmei)
'ブックの形式を取得
keisiki = wb.FileFormat
'新規ブックの追加
Workbooks.Add
Set newwb = ActiveWorkbook
'ブックのシート数取得
wscnt = wb.Worksheets.Count
For i = 1 To wscnt
'シート名取得
wsmei = wb.Worksheets(i).Name
'新規ブックのシート数が足りなかったら
If newwb.Worksheets.Count < i Then
'シートを新規ブックの末尾に追加
Worksheets.Add after:=newwb.Worksheets(i - 1)
'アクティブシートを変数wsに格納
Set ws = ActiveSheet
'新規ブックのシート数が足りていたら
Else
'i番目のシートを変数wsに格納
Set ws = newwb.Worksheets(i)
End If
'シート名を変更
ws.Name = wsmei
Next i
'元のブックを閉じる
wb.Close , False
Set wb = Nothing
'1番目のシートのA1セルにカーソル移動
Application.Goto newwb.Worksheets(1).Cells(1, 1), True
'新規ブックのパス指定
newwbpath = newfol & "\" & wbmei
'新規ブック保存
newwb.SaveAs Filename:=newwbpath, FileFormat:=keisiki
'新規ブック閉じる
newwb.Close
Set newwb = Nothing
'イベント抑制の解除
Application.EnableEvents = True
wbmei = Dir()
Loop
'新規ブックのシート数を既定の数に戻す
Application.SheetsInNewWorkbook = wsnum
Application.ScreenUpdating = True
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
