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を閉じマクロ実行すると問題なく実行します。

A 回答 (2件)

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



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
    • good
    • 0
この回答へのお礼

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

お礼日時:2017/06/17 08:25
    • good
    • 0
この回答へのお礼

ありがとう勉強します

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

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング