VBAで任意のファイルを読み出して貼り付けたい

下記を行いたいです。

マクロを実行するワークブックでマクロを実行
↓
最初に任意のエクセルファイルを開く
（これはファイル名がランダムの為、ダイアログボックスを開いてユーザに開きたいファイルを
　選択させる）
　OpenFileName = Application.GetOpenFilename（"Excelブック,*.xlsx"）
↓
開いたファイル先のシート（全セル）をコピー
↓
マクロを実行したワークブックの"sheet1”に上記コピーを貼り付け
↓
開いたファイルは保存せずに閉じる（警告メッセージ表示無し）

質問者からの補足コメント

• すみません、一つ追加です。
  
  開いたエクセルファイルをコピーする前に、そのファイルが意図しているファイルかをチェックしたいです。
  そのエクセルファイルのセルA1,B1,C1,D1,E1,F2.には、特定の文字が入力されているので、それが全て正しければ上の処理を続ける、正しくなければメッセージを出して処理を終了させたいです。

    補足日時：2018/09/10 13:54

• 開いた先のシート名はランダムです。でもワークシートは一つしかありません。
  特定の文字は、A1:①、B1:②、C1:③、D1:④、E1:⑤、F2:⑥でお願いします。

    補足日時：2018/09/10 20:34

No.4 ベストアンサー 回答者： tatsu99 回答日時： 2018/09/11 01:02

以下のマクロを標準モジュールへ登録してください。

----------------------------------------------
Option Explicit
Public Sub シートコピー()
Dim OpenFileName As Variant
Dim keys As Variant
Dim rngs As Variant
Dim i As Long
Dim wb As Workbook
OpenFileName = Application.GetOpenFilename("Excelブック,*.xlsx")
If OpenFileName = False Then Exit Sub
Set wb = Workbooks.Open(OpenFileName)
keys = Array("①", "②", "③", "④", "⑤", "⑥")
rngs = Array("A1", "B1", "C1", "D1", "E1", "F2")
For i = 0 To UBound(keys)
If Range(rngs(i)).Value <> keys(i) Then
MsgBox ("不正特定文字。処理を終了します。")
wb.Close (False)
Exit Sub
End If
Next
wb.ActiveSheet.Cells.Copy ThisWorkbook.Worksheets("Sheet1").Cells(1, 1)
wb.Close (False)
MsgBox ("コピー完了")
End Sub

この回答へのお礼

ありがとうございました。
やりたい事が出来ました。

お礼日時：2018/09/11 14:45

No.5 回答者： WindFaller 回答日時： 2018/09/11 14:44

No.3の回答者です。

失礼しました。

>A1:①、B1:②、C1:③、D1:④、E1:⑤、F2:⑥でお願いします。

修正項目
＋1を入れてください。
If (UBound(arChk) +1)<> Rng.Cells.Count Then MsgBox "Inside Err(設定ミス)", vbCritical: Exit

'チェックする文字を入れる
Const strCHEK As String = "①,②,③,④,⑤,⑥"　　'カンマ区切りです。
'チェックするセルを入れる
Const strADR As String = "A1,B1,C1,D1,E1,F2"　'カンマ区切りです。

この回答へのお礼

ありがとうございました。
やりたいことが出来ました。

お礼日時：2018/09/11 14:49

No.3 回答者： WindFaller 回答日時： 2018/09/10 20:23

こんばんは。

>開いたファイル先のシート（全セル）をコピー
>マクロを実行したワークブックの"sheet1”に上記コピーを貼り付け

これをするということは、1回きりを意味しませんか？
実際は、もう少し工夫が必要なような気がします。
ユーザー設定のところに、チェック項目の文字とセルのアドレスを入れてください。
最低限のエラー処理はしてあります。

'//標準モジュール
Sub FileOpenCopy()
Dim FileName As Variant
Dim wb As Workbook
FileName = Application.GetOpenFilename("Excelファイル,*.xlsx")
If FileName = False Then Exit Sub
On Error Resume Next
Set wb = Workbooks.Open(FileName)
If Err() <> 0 Then
　MsgBox "オープン時にエラーが発生しましたので、終了します。", vbCritical
　wb.Close False
End If
On Error GoTo 0
With wb
　If shChecker(.ActiveSheet) Then
　 .ActiveSheet.Cells.Copy ThisWorkbook.ActiveSheet.Cells(1, 1)
　 MsgBox "コピーは正常に終了しました。", vbInformation
　Else
　 MsgBox "目的のシートの整合性が合わなかったので、コピーしないまま閉じます。", vbExclamation
　End If
　.Close False
End With
End Sub
Function shChecker(ByVal sh As Worksheet) As Boolean
'******ユーザー設定 *****
'チェックする文字を入れる
Const strCHEK As String = "A,B,C,D,E,F"
'チェックするセルを入れる
Const strADR As String = "A1,B1,C1,D1,E1,F2"
'**************************
Dim arChk: arChk = Split(strCHEK, ",")
Dim Rng As Range: Set Rng = sh.Range(strADR)
If UBound(arChk) <> Rng.Cells.Count Then MsgBox "Inside Err(設定ミス)", vbCritical: Exit Function
Dim i As Long, c

For Each c In Rng
　If StrComp(Trim(arChk(i)), Trim(c.Value), vbTextCompare) <> 0 Then
　 Exit For
　End If
　i = i + 1
Next
If i > UBound(arChk) Then
　shChecker = True
End If
End Function

この回答へのお礼

ありがとうございます。
Inside Err(設定ミス)→"目的のシートの整合性が合わなかったので、コピーしないまま閉じます。"のルーチンに入りました。
ユーザ設定のところは合っています。

お礼日時：2018/09/11 13:25

No.2 回答者： tatsu99 回答日時： 2018/09/10 18:44

＞A1,B1,C1,D1,E1,F2.には、特定の文字が入力されているので、

特定の文字を提示してください。

No.1 回答者： tatsu99 回答日時： 2018/09/10 18:43

開いたファイル先のシートのシート名は何でしょうか？