エクセルVBAで別BOOKに「名前の定義」のCopy

前からあったエクセルのファイルのどこかが壊れたらしく、ときどき作業中に突然エラーとなってエクセル自体が落ちてしまうので、BOOKの複製では意味がないと考え、同じ内容のものを別BOOKに再作成するマクロを以下のとおり作ってみました。（新規作成のBOOKにこのマクロを貼ります）
これで、VBAのモジュールを除き、再作成できたのですが、どういうわけか「名前の定義」を行なったセル範囲の一部が反映されません。
調べてみると、他のセルから参照されていない「名前の定義」がすっぽり抜け落ちるようにも思えるのですが、この理解であっているでしょうか？
他のセルから参照していなくとも、マクロで参照しているので抜け落ちるのは困ります。
どうすれば、すべての「名前の定義」が再作成されるでしょうか？

Sub Book_Copy()

Dim fn As String
Dim wb1 As Workbook, wb2 As Workbook
Dim ans As Integer, i As Integer
Dim nm As Name
Dim sh As Worksheet

fn = Application.GetOpenFilename("エクセル ファイル (*.xls), *.xls")
If fn = "False" Then Exit Sub

Application.EnableEvents = False
Set wb1 = Workbooks.Open(Filename:=fn, UpdateLinks:=1)
Set wb2 = ThisWorkbook

ans = MsgBox(wb1.Name & "を " & wb2.Name & " へCopyしますか？", vbYesNo + vbQuestion)
If ans = vbNo Then Exit Sub

For Each nm In wb2.Names
nm.Delete
Next nm

For Each sh In wb1.Worksheets
sh.Cells.Copy
i = i + 1
If wb2.Worksheets.Count = i Then
wb2.Worksheets.Add After:=Worksheets(i)
Application.DisplayAlerts = False
wb2.Activate
wb2.Worksheets(i).Activate
wb2.Worksheets(i).Cells.Select
ActiveSheet.Paste
wb2.Worksheets(i).Name = sh.Name
Application.DisplayAlerts = True
Application.CutCopyMode = False
End If
Next sh

wb1.Close (False)
Application.EnableEvents = True
ActiveWorkbook.ChangeLink Name:=fn, NewName:=wb2.Name, Type:=xlExcelLinks
Set wb1 = Nothing
Set wb2 = Nothing

End Sub

No.1 ベストアンサー 回答者： Wendy02 回答日時： 2008/03/13 23:58

こんばんは。

コードをみる限りは、「名前の定義」が写されているようには思えないのですが……。

それは、ともかく、別の掲示で、最近、VBA自身の取り扱いとしては「名前の定義」に難色を示したのですが、「名前の定義」の設定は、文字列の数式なのですね。つまり、VBAとしては、数式と同じなのだと思います。ただ、そう、安易に考えないほうがよいかもしれません。理由は、Names の親オブジェクトの問題です。


細かいところは、良く検討されていませんが、こちらで、少し、書き直してみました。

Sub Book_Copy2()
　　Dim fn As String
　　Dim wb1 As Workbook, wb2 As Workbook
　　Dim ans As Integer, i As Integer
　　Dim n As Integer, m As Integer
　　Dim nm As Name
　　
　　fn = Application.GetOpenFilename("エクセル ファイル (*.xls), *.xls")
　　If fn = "False" Then Exit Sub
　　
　　Application.EnableEvents = False
　　
　　Set wb1 = Workbooks.Open(Filename:=fn, UpdateLinks:=1)
　　Set wb2 = ThisWorkbook
　　
　　ans = MsgBox(wb1.Name & "を " & wb2.Name & " へCopyしますか？", vbYesNo + vbQuestion)
　　If ans = vbNo Then Exit Sub
　　
　　For Each nm In wb2.Names
　　　　nm.Delete
　　Next nm
　　
　　n = wb1.Worksheets.Count
　　m = wb2.Worksheets.Count
　　If n > m Then
　　　　wb2.Worksheets.Add After:=wb2.Worksheets(m), Count:=n - m
　　End If
　　
　　For i = 1 To m
　　　　wb1.Worksheets(i).Cells.Copy wb2.Worksheets(i).Range("A1")
　　　　wb2.Worksheets(i).Name = wb1.Worksheets(i).Name
　　Next i
　　'名前定義の移し変え
　　For Each nm In wb1.Names
　　　　With nm
　　　　　　wb2.Names.Add .Name, .RefersTo, True
　　　　End With
　　Next nm
　　wb1.Close False
　　Application.EnableEvents = True
　　On Error Resume Next
　　ActiveWorkbook.ChangeLink Name:=fn, NewName:=wb2.Name, Type:=xlExcelLinks
　　On Error GoTo 0
　　Set wb1 = Nothing
　　Set wb2 = Nothing
End Sub

この回答へのお礼

Wendy02さま、大変ありがとうございます。
おかげさまで目的を達することができます。

> コードをみる限りは、「名前の定義」が写されているようには思えないのですが……。

ActiveWorkbook.ChangeLink Name:=fn, NewName:=wb2.Name, Type:=xlExcelLinks
で定義も写されますよ。ただし、参照されているのだけでしたが。

> '名前定義の移し変え
> For Each nm In wb1.Names
> With nm
> wb2.Names.Add .Name, .RefersTo, True
> End With
> Next nm

なるほど、全部やるにはこうやるんでね。勉強になります。
最後にもう一ついいですか？

.RefersTo, True　は　nm　の範囲をそのままという理解でいいですか？
（通常は RefersToR1C1:="=SheetC!R2C3:R6C5"とか範囲を指定しなければいけないので）

お礼日時：2008/03/14 09:58

No.2 回答者： Wendy02 回答日時： 2008/03/14 11:48

こんにちは。

>.RefersTo, True　は　nm　の範囲をそのままという理解でいいですか？
>（通常は RefersToR1C1:="=SheetC!R2C3:R6C5"とか範囲を指定しなければいけな
いので）

細かいことは調べていませんが、数式と同じ考え方ではないでしょうか？
本来、Ver.4以前のオブジェクトでない限りは、内部的には、原形のようなものがって、それを、そのまま移すと考えました。プロパティに選択肢を持っているものは、明示的に、R1C1 スタイルにする必要はないと思います。

この回答へのお礼

ありがとうございます。
助かりました。

お礼日時：2008/03/14 12:09