Excel 2016 Later 2013以前に作成したブックから新規ブックにワークシートを複写するとレイアウトが崩れる

あまりまだ言われていない原因

今まで言われているのは、列幅や列の高さが複写でうまくいかないというのはあります。
https://forest.watch.impress.co.jp/docs/serial/exceltips/1202359.html

2021/05/26追記

ここで書いている以上のことが集まっています
Excelから游ゴシック体を徹底的に駆逐する Part1
Excelから游ゴシック体を徹底的に駆逐する Part2
Excelから游ゴシック体を徹底的に駆逐する Part3
特にPart3が集大成です。
テキストボックスだけではなく、ヘッダーやフッター、スタイルまで変えています。

デフォルトフォントが游ゴシック11になりレイアウトが崩れる

今回発見したのはこれが原因でレイアウトが崩れることがありえることがわかったという点です。

Excel 2016 ,Excel 2019で発生する

初期設定は

• 見出しのフォントか游ゴシック
• テーマのフォントが游ゴシックLight
• 標準のフォントが游ゴシック

条件が確定的にわかっていませんが、いずれかになっていると発生しうるようです。
つまり初期設定を変えずに、[すべて選択] CTrl+1 フォントを変更 というような場合です。
とくにExcel2013までに作成したファイルのマクロをExcel2016以降でうごかし複写した。。。という状況で発生します。

再現手順

1. Excel 2013までに作成したマクロつきExcelファイルを用意します
2. そのマクロで別のブックを新規作成して、そこにシートを複写します
3. そのシートのセルのフォントがMSゴシックやMS明朝を指定しています
4. 特に結合したセルで行の高さを変えて、「折り返して文字を表示」している場合、フォントが勝手に游ゴシックに変わってしまい、1行の文字数が変わり、行の高さも変わり、そのために文字が表示されなくなっている箇所が発生する。ページブレイク（改ページ）も変わってしまう

というものです。
Excel 2016の標準フォントをMS Pゴシックにする
Excel 2010 で作成した文書を Excel 2016 で起動し、別ブックにシートコピーを行った場合にレイアウトが崩れる

Property LetでBackword Compatibility

そこで、特に2013以前のMS P ゴシックで作成したワークシートを新たなブックに複写するときは、
念のためにStandardFontというプロパティを変えます。
それでもだめなら、テーマも変えます。（今後追加予定）
追加してみると、今度は手動でしか戻せないようです。
このため現在は断念しました。

デフォルトをMS Pゴシック11ptから変えていた場合

もしMS 明朝、12ポイントを使っていた場合には

  If AppStnFontName <> "ＭＳ 明朝" Then
  Application.StandardFont = "ＭＳ 明朝"
  End If
  If AppStnFntSize <> 12 Then
  Application.StandardFontSize = 12
  End If

この部分は
そちらに変更します。
これは等幅フォントを使い、レイアウトを崩れないようにしていた自分のようなタイプがやっています。
そうではない場合はMS Pゴシック 11ポイントが標準です。
新たなワークブックを追加する前にStandardフォントを変更し、コピーをした時点で予期しないフォントの変更を防ぎます。
サンプルのコピーをするプロシージャを用意しました。
この中ではモードを変更することに加えて、
シートごとにUsedRangeでフォントのサイズ、名前が違っていれば変更。
UsedRangeの下から1行目に向かって、RowHeightを比較して変更。
というのを加えています。
少し遅いです。
なので、計算とかを止めます。
終わったあとは、既存の設定に戻します。
VBA マクロ高速化のために停止すべき3項目
これをワークシートを別のブックを作成して複写するときに応用したものですが、これを付け加えて計算を停止する必要があります。

Option Explicit
'モジュール名 xlV16BackwardModule1
' このProperty Letはこれのみで1モジュールにしたほうが良い

Public compFlag As Boolean
Public AppStnFontName As String
Public AppStnFntSize As Long

Property Let xlBackWordCompatibility(compFlag As Boolean)
  Debug.Print Application.StandardFont, Application.StandardFontSize
  AppStnFontName = Application.StandardFont
  AppStnFntSize = Application.StandardFontSize
  If Excel.Application.Version < 16 Then Exit Property
If compFlag Then
' ここを有効にすると、たしかにOffice 2010-2007 モードになるが、効果が不明なうえに、さらに元のモードに戻せない
' 現在はコメントアウトにしているが、テーマまで2010にしたい場合は有効にしてもいいかもしれない
' サンプルにあるように、シートを複写したら、行の高さ、セルのフォント設定、サイズを複写する
' このためセルの中で複数のフォントサイズを設定しているなど、細かい設定をしていた場合は、完全に複写できない
' なお、ここを有効にする前に、必ず複写元のファイルのテーマ、テーマフォント、カラー、エフェクトがなにか確認しておくこと
' 終わったあと、手動で戻す必要がある
'If Excel.Application.Version >= 16 Then
'    ActiveWorkbook.Theme.ThemeColorScheme.Load ( _
'        Envion("Programfiles") & "\Microsoft Office\root\Document Themes 16\Theme Colors\Office 2007 - 2010.xml")
'    ActiveWorkbook.Theme.ThemeFontScheme.Load ( _
'         Envion("Programfiles") & "\Microsoft Office\root\Document Themes 16\Theme Fonts\Office 2007 - 2010.xml")
'    ActiveWorkbook.Theme.ThemeEffectScheme.Load ( _
'        Envion("Programfiles") &  "\Microsoft Office\root\Document Themes 16\Theme Effects\Office 2007 - 2010.eftx")
'End If
REM 標準のMS Pゴシック11ptとしているが、標準のフォント、フォントのサイズを変更していた場合にはこの部分を変更すること
  If AppStnFontName <> "ＭＳ Ｐゴシック" Then
  Application.StandardFont = "ＭＳ Ｐゴシック"
  End If
  If AppStnFntSize <> 11 Then
  Application.StandardFontSize = 11
  End If
Else
  If AppStnFontName = "" Then
  Application.StandardFont = "游ゴシック"
  Else
  Application.StandardFont = AppStnFontName
  End If
  If AppStnFntSize <> 11 Then
  Application.StandardFontSize = 11
  End If
End If
End Property

行の高さ、UsedRangeのセルのフォント、サイズを複写するサンプルマクロ

これはハイスピードモード推奨です。
さらにSleep等を付け加えたほうがいい場合があると思います。
また、セルの中で複数のフォントサイズを使っていた場合などはうまくいきません。
そうした場合には個別にアドレスを設定してコピーし直す必要があります。
それでもだめな場合には手動でコピーせざるを得ません。

Sub CopySheettoNewWorkbook()
' Excel 2010以前に作成したxls*ファイルのワークシートをExcel 2016 Later でシートを別のワークブックを作成して複写するマクロ
' Sampleのため、保存しないで終わる
' 2021/02/26
compFlag = True
Dim wb As Workbook, wbD: Set wb = Excel.ThisWorkbook
' 保存したパスに保存する。このため、複写元が最新でかつ保存済かをチェック。保存が完了していない場合は終了
If wb.Saved = False Then Debug.Print "未保存終了" : Exit Sub
Dim ws As Worksheet, wsD As Worksheet
Dim SNAr() As String
Dim i As Long, iCol As Long, iRow As Long, iSht As Long
Dim sPath As String, wbName As String
' Dim xlTmC As ThemeColor, xltmCs As ThemeColorScheme, xltmEs As ThemeEffectScheme, xltmFont As ThemeFont, xltmFonts As ThemeFonts, xlTmFntSchm As ThemeFontScheme
sPath = wb.Path
wbName = "DestinyWorkbook.xlsx" '複写先のファイル名
' 新規ワークブックを作成
Set wbD = Application.Workbooks.Add
' コピーするワークシート名を設定
SNAr = Split("Bluerain,TommorowsPerfume,ShiningPolaris", ",") ' シート名を左から右へ順次並べる。面倒だが、正確に順序までコピーするときはわかりやすい
' Hispeed Property
For i = UBound(SNAr) To 0 Step -1
Debug.Print SNAr(i)
' -------------
' 必要なら除外条件を書く
If fnWorksheetExists(wb, SNAr(i)) = False Then GoTo Continue1 'シート名が存在するかが条件
'If wb.Worksheets(SNAr(i)).Range("A1").Value = "" Then GoTo Continue1 'セルの値を条件
' -------------
Set ws = wb.Worksheets(SNAr(i))
iSht = wbD.Worksheets.Count
ws.Copy after:=wbD.Worksheets(iSht)
Set wsD = wbD.Worksheets(SNAr(i))
' UsedRangeの行の高さを設定
' セル結合が複雑だと失敗するかもしれない
For iRow = ws.UsedRange.Rows.Count To 1 Step -1
wsD.Rows(iRow & ":" & iRow).RowHeight = ws.Rows(iRow & ":" & iRow).RowHeight: DoEvents
Next iRow
' UsedRangeのFontを設定
For iRow = ws.UsedRange.Rows.Count To 1 Step -1
For iCol = ws.UsedRange.Columns.Count To 1 Step -1
wsD.Range(Cells(iRow, iCol).Address).Font.Name = ws.Range(Cells(iRow, iCol).Address).Font.Name
wsD.Range(Cells(iRow, iCol).Address).Font.Size = ws.Range(Cells(iRow, iCol).Address).Font.Size
Next iCol
Next iRow
Continue1:
Next i
' 複写が成功したら、最初の1枚目のシートを削除
' 現在の標準の新規作成したら1枚しかシートがつかないことが前提
If wbD.Worksheets.Count > 1 Then
wbD.Activate
Application.DisplayAlerts = False
wbD.Worksheets(1).Delete
End If
' 細かい除去作業を開始----------
' 数式を必要なら削除
' 安全性のチェック
' 隠し行列の削除
' シートごとの独自の設定など、上記の作業でも残るようなものを削除
' 個別にアドレスを設定してコピーし直す必要があるものを複写
' エラーのある名前（セル範囲名前）の有無をチェック 必要なら削除
' Bookの保存を開始----------
sPath = sPath & "\" & wb.Name
' 同名のファイル名があるかチェック
wbD.Close False ' sampleのため保存しない
GoTo Terminator
Terminator:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.ActiveWindow.Zoom = 100
wb.Worksheets(1).Activate
compFlag = False '設定を戻す
End Sub

Function fnWorksheetExists(wb As Workbook, ReqName As String)
' Worksheetの名前が存在するか
' wbに存在しない名前はFalseを返す
Dim wsa As Worksheet
For Each wsa In wb.Worksheets
If wsa.Name = ReqName Then
fnWorksheetExists = True
Exit Function
End If
Next
fnWorksheetExists = False
End Function