変奏現実

Option Explicit

Public Sub アクティブなブックのセル値を値に変換して保存()
On Error GoTo err1
    Call 非表示のワークシートを削除する(ActiveWorkbook)
    Call ワークシートのセル値を値に変換して保存(ActiveWorkbook)
    Call 普通のEXCELファイルに保存(ActiveWorkbook)
exit1:
    Exit Sub
err1:
    MsgBox Err.Description
    GoTo exit1
End Sub

Private Sub 非表示のワークシートを削除する(ByRef ワークブック As Excel.Workbook)
    Dim ワークシート As Excel.Worksheet
    For Each ワークシート In ワークブック.Worksheets
      If ワークシート.Visible <> Excel.XlSheetVisibility.xlSheetVisible Then
        '確認メッセージを非表示にする設定
        Excel.Application.DisplayAlerts = False
        '非表示のワークシートを削除
        ワークシート.Delete
        '確認メッセージを表示する設定
        Excel.Application.DisplayAlerts = True
      End If
    Next
End Sub

Private Sub ワークシートのセル値を値に変換して保存(ByRef ワークブック As Excel.Workbook)
    '全シート選択
    '条件：事前に非表示なワークシートは削除済みであること
    '非表示なワークシートが残っている場合は ワークブック.Sheets(Array("Sheet1", "Sheet2")).Selectな感じで表示ワークシートに限定して選択すること ）
    ワークブック.Sheets.Select
    '全ワークシートを選択
    ワークブック.Application.Cells.Select
    '全ワークシートをコピー
    ワークブック.Application.Selection.Copy
    '全ワークシートへ値としてペースト
    ワークブック.Application.Selection.PasteSpecial Paste:=xlPasteValues, _
      Operation:=xlNone, _
      SkipBlanks:=False, _
      Transpose:=False
    'コピペモードの解除
    ワークブック.Application.CutCopyMode = False
    'シート全体を選択したままになっているので、
    'A1のみ選択の状態にする
    Call ワークブック.Application.Cells(1, 1).Select
End Sub

Private Sub 普通のEXCELファイルに保存(ByRef ワークブック As Excel.Workbook)
    Dim ファイル名 As String
    '拡張子を削除　※削除しないと拡張子が重複する
    ファイル名 = Replace(ワークブック.FullName, ".xlsm", "")
    '確認メッセージを非表示
    ワークブック.Application.DisplayAlerts = False
    '普通のExcelファイルに保存
    ワークブック.SaveAs Filename:=ファイル名, _
      FileFormat:=xlOpenXMLWorkbook, _
      Password:="", _
      WriteResPassword:="", _
      ReadOnlyRecommended:=False, _
      CreateBackup:=False
    '確認メッセージを表示
    Application.DisplayAlerts = True
    '処理完了メッセージ
    MsgBox ファイル名 & ".xlsx" & vbCrLf & "に名前を変えて保存しました"    
End Sub