変奏現実

'全シート選択
Dim worksheet As Worksheet
Dim wss() As String
Dim cnt As Integer
cnt = 0
For Each worksheet In Worksheets
  If worksheet.Visible = xlSheetVisible Then
    cnt = cnt + 1
    ReDim Preserve wss(cnt -1)
    wss(cnt - 1) = woeksheet.Name
  Else
    '確認メッセージを非表示
    Application.DisplayAlerts = False
    'ワークシートを削除
    worksheet.Delete
    '確認メッセージを表示
    Application.DisplayAlerts = True
  End If
Next
Sheets(wss).Select

'コピー
Cells.Select
Selection.Copy

’データ貼り付け
Selection.PasteSpecial Paste:= xlPasteValues, _
  Operation:= xlNone, _
  SkipBlanks:= False, _
  Transpose:= False

'セル選択の解除
Application.CutCopyMode = False

Dim bookName as String
bookName = ActiveWorkbook.Name
bookName = Replace(ActiveWorkbook.Name,".xlsm","xlsx")
Dim bookNamePath
bookNamePath = Split(ActiveWorkbook.FullName,"\")
ReDim Preserve bookNamePath(UBound(bookNamePath)-1)
bookNamePath = Join(bookNamePath,"\")
ChDir bookNamePath
'確認メッセージを非表示
Application.DisplayAlerts = False
'普通のExcelファイルに保存
ActiveWorkbook.SaveAs Filename:= bookName, _
  FileFormat:= xlOpenXMLWorkbook, _
  Password:= "", _
  WriteResPassword:= "", _
  ReadOnlyRecommended:= False, _
  CreateBackup:= False
'確認メッセージを表示
Application.DisplayAlerts = True
'処理完了メッセージ
MsgBox bookNamePath & "\" & bookName & vbCrLf & "へ名前を変えて保存"