他ブックからのシートコピーのマクロ 外部参照修正

追い詰められているマクロ初心者です。
ネットで相談させていただき、下記マクロを完成する事が出来たのですが、
一部修正がうまくいかない為投稿させていただきました。
マクロ内容：エクセルファイルを指定し、選択したシートを現在のブックにコピーする
その際、不要な名前管理を削除してからコピー

修正したい箇所：指定したブックからコピーした際、シート参照の数式が入っていると外部参照になってしまう。

やってみた事：①(i)の前にarrayを入れる 外部参照のまま
②(i)を削除してみた 外部参照にならなくたったが際限なくシートをコピーし続けた


Sub 名前管理削除()
Dim myPath As String
Dim wb_A As Workbook
Dim i As Integer
'
myPath = Application.GetOpenFilename(("Excelファイル,*.xls*,CSVファイル,*.csv"), , "ブックを選択して下さい。")
If myPath = "False" Then Exit Sub
Set wb_A = Workbooks.Open(myPath)
Dim name As Object

For Each name In Names
If name.Visible = False Then
name.Visible = True
End If
Next
On Error Resume Next ' エラーを無視。(削除件数にカウントしてしまいます)
For Each nm In ActiveWorkbook.Names
If InStr(nm.Value, "#REF") > 0 Or _
InStr(nm.Value, "\") > 0 Then
nm.Delete
i = i + 1
Else

End If
Next nm
' 終了の表示
MsgBox "不要な名前定義を削除しました。" & vbCr & _
"削除定義件数=" & i & "件", vbInformation, cnsTitle
For i = 1 To wb_A.Sheets.Count
wb_A.Sheets(i).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Next
wb_A.Close False
End Sub


不勉強で申し訳ございませんが、何卒よろしくお願いいたします。

No.2 回答者： blue_rumble 回答日時： 2019/07/12 18:08

＞やってみた事：①(i)の前にarrayを入れる

とありますが、「wb_A.Sheets(array(i))」と記述したのなら、参照が設定されてしまいます。

参照設定させないためには、全シートを一括でコピーさせる必要があり、そのためにarray()を使用します。

最後のForループで、いきなりコピーせず、1つずつシート名を取得します。
（配列に格納すると良いと思います）

その後に、array()の中に、取得した全てのシート名を列記すれば大丈夫です。

この回答へのお礼

お忙しいところ本当にありがとうございました。ご回答いただきましたサンプルをもとに、じっくり修正してみたいと思います。本当にありがとうございました！

お礼日時：2019/07/15 11:01

No.1 回答者： WindFaller 回答日時： 2019/07/11 14:50

少し直してみましたが、マクロでは除去できないものがあります。

以前、それ専用のマクロを作ったことがありますが、基本的には、無理だったような気がします。
それで、エラーを出したら、エラーを出した数を数えるようにしました。 変数 j, k
具体的には、IFERROR という関数を使った名前定義は、セルの中に潜り込んで取れなくなったのだったという記憶があります。
不要な名前定義の削除について、このサンプルをとおして検討し直してみてください。


'//
Sub 名前管理削除r()
　Dim myPath As String
　Dim wb_A As Workbook
'　Dim i As Integer
　'
　myPath = Application.GetOpenFilename(("Excelファイル,*.xls?,CSVファイル,*.csv"), , "ブックを選択して下さい。")
　If myPath = "False" Then Exit Sub
　Set wb_A = Workbooks.Open(myPath)
　'------------------------
　Dim n As Name
　Dim nn As String
　Dim j As Long, k As Long
　Dim r As Range, b As Range
　Const cnsTitle = "名前削除"
　For Each n In wb_A.Names
　　n.Visible = True
　　nn = Mid(n.RefersToLocal, 2)
　　If IsError(Evaluate(n.Value)) Then
　　　On Error Resume Next
　　　n.Delete
　　　If Err() <> 0 Then
　　　　k = k + 1
　　　Else
　　　　j = j + 1
　　　End If
　　　On Error GoTo 0
　　Else
　　　Set r = Range(nn)
　　　If IsError(r) Then
　　　　n.Delete
　　　　j = j + 1
　　　ElseIf InStr(nn, "\") > 0 Then
　　　　n.Delete
　　　　j = j + 1
　　　End If
　　End If
　Next
　If j > 0 Or k > 0 Then
　　MsgBox "不要な名前定義を削除しました。" & vbCr & _
　　　"削除定義件数=" & j & "件" & vbCrLf & _
　　　"削除失敗件数 =" & k & "件", vbInformation, cnsTitle
　End If
　If j > 0 Or k > 0 Then
　　MsgBox "名前削除に失敗しましたので、中止します。", vbCritical
　　Exit Sub
　End If
　'----------------------------
　For i = 1 To wb_A.Sheets.Count
　　wb_A.Sheets(i).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
　Next
　wb_A.Close False

End Sub

この回答へのお礼

お忙しいところご丁寧にありがとうございました。ご回答いただきましたサンプルを元にじっくりと検討したいと思います。本当にありがとうございました。

お礼日時：2019/07/15 10:59