複数の同じようなExcelファイルに対して、マクロ除去とフォントの一括変換をおこないたい

Question

同じシート構成で中身の違うエクセルファイルが複数あります。

これらのエクセルファイルの
0. フォントファミリーの変更（ＭＳ ＰゴシックとＭＳ ゴシックにしたい）
0. フォーム、マクロを除去

を行いたいです。
方法としては、Powershellで回す。VBAで回す。C#でNPOIを使う。あたりを候補にしています。
（1回限りなので何でもいいです。VBAはあまりわからないのですが、対象のオブジェクトがわかればなんとかなるのではないかと思っています）。

シートはどのエクセルも同じ名前で同じインデックスのものが5シートあります。
フォントファミリー以外のフォントのスタイルは変更したくありません。

フォーム、マクロは全て名称は同じです。

どのオブジェクトに対してどのような操作を行えば良いかを教えていただけると助かります。
よろしくお願いします。

Answer 1

こんなんでどうでしょうか。
bfs配列に対象となるブックのファイル名を入れてください。
あとは全ブック・全セルに対してフォント名を変更します。
オブジェクトも対象にしたいのであれば別途（時間があれば）検討します。
マクロを削除する処理は、ファイル形式をxlsxに変更することで対応しています。
xlsmのままマクロのみを削除したいのであれば、また別途（時間があれば）検討してみます。
あと、すみません、なぜか途中でエラーが発生します（変換は最後まで行ってるようなんですが、調べる時間が…）

Dim wb As Workbook
Dim bfs(5) As Variant
Dim bf
bfs(0) = "c:\temp\book1.xlsm"
bfs(1) = "c:\temp\book2.xlsm"
bfs(2) = "c:\temp\book3.xlsm"
bfs(3) = "c:\temp\book4.xlsm"
bfs(4) = "c:\temp\book5.xlsm"
Application.DisplayAlerts = False
For Each bf In bfs
    Set wb = Workbooks.Open(bf)
    For Each ws In wb.Worksheets
        ws.Cells.Font.Name = "ＭＳ ゴシック"
    Next
    wb.SaveAs Filename:=Replace(bf, "xlsm", "xlsx"), FileFormat:=xlOpenXMLWorkbook
    wb.Close
Next
Application.DisplayAlerts = True

Comments

[hos]

ありがとうございます。
試してみてまた報告します。
フォントの書き方はこんな感じなんですね。
拡張子はxlsで、マクロを解放したいので、そこはもう少し考えてみます。

Answer 2

xlsからxlsxへの変換も行う必要があったので ttyp03 さんにいただいた回答と下記のURLの情報を元にマクロを作成しました（ほぼコピペしただけです）。

xlsからxlsxへの変換 http://excel-ubara.com/excelvba5/EXCELVBA251.html
マクロの除去 http://chaichan.lolipop.jp/vbtips/VBMemo2006081403.htm

Sub xls2xlsx()

    Dim i As Long
    Dim strArray() As String
    Dim strFile As String
    Dim strPath As String
    Dim strBook As String
        
    strPath = ThisWorkbook.Path & "\source\"
    strDistPath = ThisWorkbook.Path & "\excel\"
    strFile = Dir(strPath & "*.xls")
    i = 0
    Do While strFile <> ""
        If LCase(Right(strFile, 4)) = ".xls" Then
            ReDim Preserve strArray(i)
            strArray(i) = strFile
            i = i + 1
        End If
        strFile = Dir()
    Loop
    For i = 0 To UBound(strArray)
        With Workbooks.Open(strPath & strArray(i))
            strBook = Left(strArray(i), InStrRev(strArray(i), ".") - 1)
            ' フォント変更
            For Each ws In .Worksheets
                ws.Cells.Font.Name = "ＭＳ ゴシック"
            Next
            
                        
            If .HasVBProject Then
                ' ここからマクロ除去
                Dim objVbcompo As Object
                For Each objVbcompo In .VBProject.VBComponents
                
                    With objVbcompo.CodeModule
                        If .CountOfLines <> 0 Then .DeleteLines 1, .CountOfLines
                    End With
                    If (objVbcompo.Type = vbext_ct_StdModule Or objVbcompo.Type = vbext_ct_MSForm) Then
                        .VBProject.VBComponents.Remove objVbcompo
                    End If
                Next objVbcompo
                'ここまでマクロ除去
                Set objVbcompo = Nothing
 '               If Dir(strPath & strBook & ".xlsm") = "" Then
 '                   .SaveAs Filename:=strPath & strBook & ".xlsm", _
 '                           FileFormat:=xlOpenXMLWorkbookMacroEnabled
 '               Else
 '                   .SaveAs Filename:=strPath & strBook & "_" & Format(Now(), "yyyymmddhhmmss") & ".xlsm", _
 '                           FileFormat:=xlOpenXMLWorkbookMacroEnabled
 '               End If
                Application.DisplayAlerts = False
                If Dir(strDistPath & strBook & ".xlsx") = "" Then
                    .SaveAs Filename:=strDistPath & strBook & ".xlsx", _
                            FileFormat:=xlWorkbookDefault
                Else
                    .SaveAs Filename:=strDistPath & strBook & "_" & Format(Now(), "yyyymmddhhmmss") & ".xlsx", _
                            FileFormat:=xlWorkbookDefault
                End If
            Else
                If Dir(strDistPath & strBook & ".xlsx") = "" Then
                    .SaveAs Filename:=strDistPath & strBook & ".xlsx", _
                            FileFormat:=xlWorkbookDefault
                Else
                    .SaveAs Filename:=strDistPath & strBook & "_" & Format(Now(), "yyyymmddhhmmss") & ".xlsx", _
                            FileFormat:=xlWorkbookDefault
                End If
            End If
            .Close savechanges:=False
        End With
    Next


End Sub