質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

87.61%

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

解決済

回答 2

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 3,523

score 30

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

これらのエクセルファイルの

  1. フォントファミリーの変更(MS PゴシックとMS ゴシックにしたい)
  2. フォーム、マクロを除去

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

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

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

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

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 2

+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 = "MS ゴシック"
    Next
    wb.SaveAs Filename:=Replace(bf, "xlsm", "xlsx"), FileFormat:=xlOpenXMLWorkbook
    wb.Close
Next
Application.DisplayAlerts = True

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2017/06/28 19:26 編集

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

    キャンセル

check解決した方法

0

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 = "MS ゴシック"
            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

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 87.61%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る