Excel2007が必要だけどxlsxをxlsに一括変換

追記:いまならDownload: Word/Excel/PowerPoint 用 Microsoft Office 互換機能パック - Microsoft Download Center - Download Detailsとか無料総合オフィスソフトウェア - Apache OpenOffice.org 日本語プロジェクト

<移行分>
嫁さんのPCのExcelが2007。会社のPCはXPらしく2003。ファイル形式が変わったようでそのままじゃ開けないらしい。保存しなおしても良いけど面倒なので保存しなおすマクロを作りました。やってることは要はコピーをとるだけで、Excel2007が必要な時点で汎用性はない。このままだとページ設定が反映されないのでコピーすると良いかも。(試してないけど互換性なさそう…。2003にあるプロパティだけコピーするのが吉?)

作ったもの: xlsx2xls.xls
http://www.asahi-net.or.jp/~kb9h-itu/vba/xlsx2xls.xls

メインルーチン。マクロを仕込んだファイルがあるフォルダのxlsxファイルをxlsファイルに変換する。

Sub Xlsx2xls()
    
    Dim fso As Object
    Dim folder As Object
    Dim file As Object
    Dim xlsxBook As Workbook
    Dim xlsBook As Workbook
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(ThisWorkbook.Path)
    For Each file In folder.files
        If Right(file.Name, 5) = ".xlsx" And Left(file.Name, 2) <> "~$" Then
            Set xlsxBook = Workbooks.Open(file.Path)
            Set xlsBook = OpenXlsBook(fso, file.Name)
            Call CopySheets(xlsxBook, xlsBook)
            Call xlsxBook.Close(False)
            Call xlsBook.Close(True)
        End If
    Next file
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = True
    
End Sub

Excel2003のxlsファイルを生成する。マクロを仕込んだファイル自体を2003で作っておき、そのコピーを生成することで代替する。

Function OpenXlsBook(ByRef fso As Object, ByVal XlsxName As String) As Workbook
    
    Dim fromName As String
    Dim toName As String
    Dim folder As String
    
    folder = ThisWorkbook.Path & "\"
    fromName = folder & ThisWorkbook.Name
    toName = folder & Left(XlsxName, Len(XlsxName) - 5) & ".xls"
    Call fso.GetFile(fromName).Copy(toName)
    Set OpenXlsBook = Workbooks.Open(toName)
    
End Function

シート上のデータコピー。シートそのもののコピーが直接できないので苦肉の策。

Sub CopySheets(ByRef fromBook As Workbook, ByRef toBook As Workbook)

    Dim sh As Worksheet
    Dim newSh As Worksheet
    
    For Each sh In fromBook.Worksheets
        Set newSh = toBook.Sheets.Add
        newSh.Name = sh.Name
        Call sh.Cells.Copy
        Call newSh.Paste
        Call sh.Cells.Copy
        Call newSh.Cells.PasteSpecial(xlPasteColumnWidths)
        Call newSh.Cells.Replace(".xlsx", ".xls")
        ' Set newSh.PageSetup = sh.PageSetup ' ページ設定のコピー?
    Next sh
    Call toBook.Worksheets("Sheet1").Delete
End Sub