Excel VBA質問箱 IV

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

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


5897 / 76735 ←次へ | 前へ→

【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

0 hits

【76438】ファイル操作について パーミッション 14/12/2(火) 15:52 質問[未読]
【76439】Re:ファイル操作について カリーニン 14/12/2(火) 19:42 発言[未読]
【76440】Re:ファイル操作について カリーニン 14/12/2(火) 20:22 発言[未読]
【76443】Re:ファイル操作について カリーニン 14/12/2(火) 22:24 発言[未読]
【76444】Re:ファイル操作について カリーニン 14/12/2(火) 22:56 発言[未読]

5897 / 76735 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free