Excel VBA質問箱 IV

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

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


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

5895 / 76733

←次へ　｜　前へ→


	【76443】Re:ファイル操作について

カリーニン - 14/12/2(火) 22:24 -


	引用なし

	パスワード

ブックの形式を取得して同じ形式で保存します。

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

4 hits

▼

【76438】ファイル操作について パーミッション 14/12/2(火) 15:52