Excel VBA質問箱 IV

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

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


8636 / 76732 ←次へ | 前へ→

【73665】Re:マクロを削除するマクロ
発言  UO3  - 13/1/31(木) 19:02 -

引用なし
パスワード
   ▼ブーチー さん:

2010では、セル全体をコピペする動作を繰り返しますと、エクセル障害になりますので
いろいろ細工をしましたが、すんなりとはいきません。
2003ならOKかもしれませんので試してみてください。

なお、実行はフォルダを2つ作り、変換すべきブックを一方のフォルダに格納してください。
マクロの最初で変換元、変換先のフォルダ指定画面がでます。
変換後のブックが同じ名前で変換先に指定したフォルダに保存されます。

Sub Sample()
  Dim fold1 As String
  Dim fold2 As String
  Dim fname As Variant
  Dim sh As Worksheet
  Dim svNewNos As Long
  Dim fromWB As Workbook
  Dim toWB As Workbook
  Dim x As Long
  Dim cl As Collection
  
  Set cl = New Collection
  
  fold1 = getFolder("変換すべきブックのフォルダを選んでください")
  If Len(fold1) = 0 Then Exit Sub
  fold2 = getFolder("変換したブックの保存フォルダを選んでください")
  If Len(fold1) = 0 Then Exit Sub
  
  If fold1 = fold2 Then
    MsgBox "変換目、返還後のフォルダを同じものにすることはできません"
    Exit Sub
  End If
  
  Application.ScreenUpdating = False
  
  svNewNos = Application.SheetsInNewWorkbook
  
  fname = Dir(fold1 & "*.xls")
  
  Do While Len(fname) > 0
    cl.Add fname
    fname = Dir()
  Loop
  
  For Each fname In cl
  
    Set fromWB = Workbooks.Open(fold1 & fname)
    Application.SheetsInNewWorkbook = fromWB.Worksheets.Count
    Set toWB = Workbooks.Add
    x = 0
    For Each sh In fromWB.Worksheets
      x = x + 1
      sh.Cells.Copy toWB.Worksheets(x).Range("A1")
      Application.CutCopyMode = False
      DoEvents
      DoEvents
    Next
    
    fromWB.Close False
    Application.DisplayAlerts = False
    toWB.SaveAs fold2 & fname
    Application.DisplayAlerts = True
    toWB.Close
    
    DoEvents
    DoEvents
    
  Next
  
  Application.SheetsInNewWorkbook = svNewNos
  Application.ScreenUpdating = True
  MsgBox "変換がおわりました"
  
End Sub

Private Function getFolder(msg As String) As String
  Dim myPath As Object
  Dim hWnd As Long
  
  Const BIF_RETURNNONLYFSDIRS = &H1 'ディレクトリのみ選択可
  Const BIF_EDITBOX = &H10 'アイテム名入力用のEdit_boxを表示
  
  hWnd = Application.hWnd
  With CreateObject("Shell.Application")
    Set myPath = .BrowseForFolder(hWnd, msg, BIF_RETURNNONLYFSDIRS Or BIF_EDITBOX)
  End With
  If Not myPath Is Nothing Then getFolder = myPath.Items.Item.Path & "\"
End Function


>▼UO3 さん:
>
>>ところでブーチーさんの環境は 2003以前ですか?2007以降ですか?
>
>2003 win7です。
>よろしくお願いいたします。
315 hits

【73649】マクロを削除するマクロ ブーチー 13/1/29(火) 16:24 質問
【73654】Re:マクロを削除するマクロ UO3 13/1/29(火) 20:49 発言
【73657】Re:マクロを削除するマクロ ブーチー 13/1/31(木) 8:15 お礼
【73659】Re:マクロを削除するマクロ UO3 13/1/31(木) 9:31 発言
【73660】Re:マクロを削除するマクロ ブーチー 13/1/31(木) 9:42 お礼
【73661】Re:マクロを削除するマクロ UO3 13/1/31(木) 11:16 発言
【73662】Re:マクロを削除するマクロ ブーチー 13/1/31(木) 11:22 発言
【73663】Re:マクロを削除するマクロ UO3 13/1/31(木) 11:32 発言
【73664】Re:マクロを削除するマクロ ブーチー 13/1/31(木) 12:08 発言
【73665】Re:マクロを削除するマクロ UO3 13/1/31(木) 19:02 発言
【73672】Re:マクロを削除するマクロ ブーチー 13/2/1(金) 9:34 発言
【73673】Re:マクロを削除するマクロ UO3 13/2/1(金) 10:07 発言
【73674】Re:マクロを削除するマクロ UO3 13/2/1(金) 10:41 発言
【73675】Re:マクロを削除するマクロ ブーチー 13/2/1(金) 10:58 お礼
【73676】Re:マクロを削除するマクロ UO3 13/2/1(金) 11:31 発言
【73655】Re:マクロを削除するマクロ ichinose 13/1/29(火) 21:08 発言
【73658】Re:マクロを削除するマクロ ブーチー 13/1/31(木) 8:23 お礼
【73682】Re:マクロを削除するマクロ ichinose 13/2/2(土) 9:24 発言
【73695】Re:マクロを削除するマクロ ブーチー 13/2/3(日) 8:14 お礼

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