取り込むブックのホルダーにあるブックを選べないその下の階層\dataホルダーから選びたいのですが
選んでコピーしてコピーしたブックは閉じたいのですが、Workbooks.Closeどこに入れてもエラーになります。教えて下さい

Sub 取り込み()
Dim myPath As String, myName As String
Dim twb As Workbook, ws As Worksheet
With ThisWorkbook
myPath = .Path & "\"
myName = Dir(myPath & "*.xls", vbNormal)
If myName <> .Name Then
Set twb = OpenBook(myPath & myName)
If Not twb Is Nothing Then
For Each ws In twb.Worksheets
If SheetCopyFLG(ws) Then
ws.Copy after:=.Worksheets(.Worksheets.Count)
End If
Next ws
End If
End If
End With
End Sub
'-------------------------------------------------------------
Function OpenBook(myName As String) As Workbook
Dim wb As Workbook
Set OpenBook = Nothing
For Each wb In Workbooks
If LCase(wb.FullName) = LCase(myName) Then
Set OpenBook = wb
Exit For
End If
Next wb
If OpenBook Is Nothing Then
On Error Resume Next
Set OpenBook = Workbooks.Open(myName)
End If
End Function
'-------------------------------------------------------------
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

A 回答 (3件)

組み込むならいかのようになります。


------------------------------------------------
Sub 取り込み()
Dim myPath As String, myName As String
Dim twb As Workbook, ws As Worksheet
With ThisWorkbook
Dim OpenFileName As String
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
------------------------------------------
ChDir ThisWorkbook.Path & "\data\"
は、不要ならコメントアウトしてください。
    • good
    • 0
この回答へのお礼

すばらしいです。
長々と、ありがとう御座いました。
感謝、感謝です。

お礼日時:2017/06/14 17:22

>取り込むブックのホルダーにあるブックを選べないその下の階層\dataホルダーから選びたいのですが


>myPath = .Path & "\"
>myName = Dir(myPath & "*.xls", vbNormal)
>このへんを直すのでしょうか

このブック(このマクロのブック)を格納してあるフォルダの直下に"data"というフォルダがあり、そのフォルダの中にブックがあるということですね。
myPath = .Path & "\data\"
のようにしてください。
    • good
    • 0
この回答へのお礼

ありがとう御座います
Dim myPath As String, myName As String
Dim twb As Workbook, ws As Worksheet
With ThisWorkbook
myPath = .Path & "\data\"
myName = Dir(myPath & "*.xls", vbNormal)
If myName <> .Name Then
Set twb = OpenBook(myPath & myName)
If Not twb Is Nothing Then
For Each ws In twb.Worksheets
If SheetCopyFLG(ws) Then
ws.Copy after:=.Worksheets(.Worksheets.Count)

これでは\dataなかのブックを勝手に取り込むので

3.名前を指定して開く
[ファイルを開く]ダイアログボックスを表示する。
Dim OpenFileName As String
OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls")
If OpenFileName <> "False" Then
Workbooks.Open OpenFileName
End If
付け加えられないでしょう

お礼日時:2017/06/14 13:43

下記の追加のコメントがあるところへ追加してください



Sub 取り込み()
Dim myPath As String, myName As String
Dim twb As Workbook, ws As Worksheet
With ThisWorkbook
myPath = .Path & "\"
myName = Dir(myPath & "*.xls", vbNormal)
If myName <> .Name Then
Set twb = OpenBook(myPath & myName)
If Not twb Is Nothing Then
For Each ws In twb.Worksheets
If SheetCopyFLG(ws) Then
ws.Copy after:=.Worksheets(.Worksheets.Count)
End If
Next ws
Workbooks(myName).Close '追加
End If
End If
End With
End Sub
    • good
    • 0
この回答へのお礼

ありがう御座います、追加してブックが閉じました。
取り込むブックのホルダーにあるブックを選べないその下の階層\dataホルダーから選びたいのですが
myPath = .Path & "\"
myName = Dir(myPath & "*.xls", vbNormal)
このへんを直すのでしょうか

お礼日時:2017/06/13 14:27

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

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


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

人気Q&Aランキング