vba勉強中

Sub 取り込み()
Dim myPath As String, myName As String
Dim twb As Workbook, ws As Worksheet
Dim OpenFileName As String
With ThisWorkbook

ChDir ThisWorkbook.Path & "\data\"
OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls")
If OpenFileName = "False" Then Exit Sub
myName = Dir(OpenFileName)
Workbooks.Open OpenFileName
For Each ws In Worksheets
If SheetCopyFLG(ws) Then 'ここにあるのですが
ws.Copy after:=.Worksheets(.Worksheets.Count)

End If
Next ws
Workbooks(myName).Close
End With
End Sub

'-------------------------------------------------------------
Function SheetCopyFLG(tws As Worksheet) As Boolean 'ここをエラーと指す
Dim ws As Worksheet
SheetCopyFLG = True
For Each ws In ThisWorkbook.Worksheets
If tws.Name = ws.Name Then
If MsgBox(tws.Name & "は存在します。コピーしますか？", _
vbYesNo + vbExclamation, "SheetCopy") <> vbYes Then
SheetCopyFLG = False
End If
Exit Function
End If
Next ws
End Function
　
マクロ自体は動くのですが、ブックを起動時にvbaの画面になりコンパイルエラー
オートメーションエラーです
致命的なエラーです
とでます、どうしてでしょうか。
bvaを閉じマクロ実行すると問題なく実行します。

No.1 回答者： tatsu99 回答日時： 2017/06/15 17:54

>オートメーションエラーです

この辺が参考になるかもしれません。

https://answers.microsoft.com/ja-jp/msoffice/for …
https://msdn.microsoft.com/ja-jp/library/office/ …
http://108freedom.hatenablog.com/entry/2016/06/2 …

この回答へのお礼

ありがとう勉強します

お礼日時：2017/06/17 08:23

No.2 ベストアンサー 回答者： WindFaller 回答日時： 2017/06/16 15:03

>オートメーションエラーです

Sub 取り込み()
With ThisWorkbook
となっていて、
For Each ws In Worksheets　'オープンしたシートを
'以下でループさせて、

Function SheetCopyFLG(tws As Worksheet)
For Each ws In ThisWorkbook.Worksheets

エラーの直接の原因は分かってはいませんが、こちらで、そのパラメータのtwsを捨てるかどうか、対話型にしているわけですが、そういう、ループのオブジェクト型の変数を、そのまま外のコードに渡すのはうまくないと思います。

If tws.Name = ws.Name Then

やっていることは文字比較なのですから、最初から、文字列で渡せばよいわけです。

Sub 取り込み()
For Each ws In twb.Worksheets
If SheetCopyFLG(ws.Name) Then
'--------------------
Function SheetCopyFLG(shName As String) As Boolean　'文字列で渡す
　Dim ws As Worksheet
　 For Each ws In ThisWorkbook.Worksheets
　　If UCase(shName) = UCase(ws.Name) Then　'文字列比較
　　　If MsgBox(shName & "は存在します。コピーしますか？", _
　　　　　　　　vbYesNo + vbExclamation, "SheetCopy") <> vbYes Then
　　　　SheetCopyFLG = False
　　　　Exit Function
　　　Else
　　　　SheetCopyFLG = True
　　　　Exit Function
　　　End If
　　End If
　Next ws
　SheetCopyFLG = True
End Function

しかし、私なら、例えば、裏技的ですが、このように、dummy(dumm) を使って、オブジェクトが取れるなら、シートがある、オブジェクトがないなら、シートはないということも可能です。

For Each ws In twb.Worksheets
　　　　On Error Resume Next
　　　　Set dumm = .Worksheets(ws.Name)
　　　　If IsEmpty(dumm) = False Then
　　　　　If MsgBox("同じシート名があります。" & ws.Name & vbCrLf & _
　　　　　"コピーしますか？", vbOKCancel) = vbOK Then
　　　　　　ws.Copy after:=.Worksheets(.Worksheets.Count)
　　　　　End If
　　　　Else
　　　　　ws.Copy after:=.Worksheets(.Worksheets.Count)
　　　　End If
　　　　dumm = Empty　'Variant 型の空の値
　　　　On Error GoTo 0
　　　Next
　　　twb.Close False
　　　End If
　　Next

この回答へのお礼

ありがとう御座います。勉強になります。

お礼日時：2017/06/17 08:25