| |
▼ブーチー さん：
2010では、セル全体をコピペする動作を繰り返しますと、エクセル障害になりますので
いろいろ細工をしましたが、すんなりとはいきません。
2003ならＯＫかもしれませんので試してみてください。
なお、実行はフォルダを２つ作り、変換すべきブックを一方のフォルダに格納してください。
マクロの最初で変換元、変換先のフォルダ指定画面がでます。
変換後のブックが同じ名前で変換先に指定したフォルダに保存されます。
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です。
>よろしくお願いいたします。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
