excel

excel
別ブックを開けずにコピーする方法
別ブックからA列〜U列全ての情報を取り込めるようにしたいのですが、その場合、下記のコードをどのように書き換えればよろしいのでしょうか？
よろしくお願い致します！

Sub Sample3()
Dim OpenFileName As String, SheetName As String, Target As String, buf As String
Dim i As Long, TargetCol As Long, GetNames()
''対象ブックを選択します
OpenFileName = Application.GetOpenFilename("Microsoft Excel ブック,*.xls")
If OpenFileName = "False" Then Exit Sub
''ファイル名に[]を付ける
OpenFileName = Replace(OpenFileName, Dir(OpenFileName), "[" & Dir(OpenFileName) & "]")
''対象ワークシート名を取得
SheetName = InputBox("読み込むワークシート名を入力してください。")
If SheetName = "" Then Exit Sub
Target = "'" & OpenFileName & SheetName & "'!"
''ワークシート名が正しいかどうか、まず読み込んでみる
On Error Resume Next
buf = ExecuteExcel4Macro(Target & "R1C1")
If Err <> 0 Then
MsgBox "ワークシート [ " & SheetName & " ] を読めませんでした。", vbExclamation
Exit Sub
End If
On Error GoTo 0
''[名前]フィールドを探す
For i = 1 To 256
If ExecuteExcel4Macro(Target & "R1C" & i) = "名前" Then
TargetCol = i
Exit For
End If
Next i
If TargetCol = 0 Then
MsgBox "[ 名前 ]フィールドが見つかりません。", vbExclamation
Exit Sub
End If
''データの読み込み
For i = 2 To 10000 ''(1)
buf = ExecuteExcel4Macro(Target & "R" & i & "C" & TargetCol)
If buf = "0" Then Exit For ''(2)
''【アクティブシートに出力する】
ActiveSheet.Cells(i - 1, 1) = buf
''【配列に格納する】
ReDim Preserve GetNames(i - 1) ''(3)
GetNames(i - 1) = buf
Next i
''配列に格納したデータの確認
For i = 1 To UBound(GetNames)
Debug.Print GetNames(i)
Next i
End Sub

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

• 

  こんばんは！ご回答頂きありがとうございます！
  私自身そこまでexcelの知識がないもので、サンプルのものを利用できないかと思いまして、、
  したいことは、別ブックに入力されたものを取り込めるようにしたいです。（取り込みたい範囲はA列〜U列まで）
  何か他に簡単なものがあればぜひご教授下さい！
  よろしくお願い致します！

  No.1の回答に寄せられた補足コメントです。 補足日時：2018/12/11 23:12

• 

  ご回答頂きありがとうございます！
  早速試させて頂いたのですがとてもすごいです！
  可能であれば、次のようになってしまう場合はどのようにすれば良いかご教授下さい！！
  
  ①おおもとのブック（取り込みたいデータがある）が、外部参照のリンク設定されているものだと、シートの選択のときに何回かループしてしまいます。
  
  ②おおもとのブック（取り込みたいデータがある）のシート名が数字だった場合、エラーとなってしまいます。（シート名が201812の時など）
  
  ③取り込むブックの方にデータが残っていると、削除しますか？と表示されるようにして頂いているのですが、毎度上書きのようにしたいので、表示されないようにしたい。
  
  度々のご質問となってしまい申し訳ございませんが、どうかよろしくお願い致します！

  No.2の回答に寄せられた補足コメントです。 補足日時：2018/12/12 14:22

• 

  ほんとうにありがとうございます！！
  明日早速試してみます！
  もしまた何かあればご相談に乗って頂けますと助かります！！

  No.3の回答に寄せられた補足コメントです。 補足日時：2018/12/13 00:21

No.3 回答者： WindFaller 回答日時： 2018/12/12 23:39

こんばんは。

>シート名が201812の時など
シート名の入れ方を変えることにしました。シート名が数字だった場合でも、可能にしただけでなく、数字の全角・半角のゆらぎをカバーすることにしました。それと、シート名にありがちな最後尾の半角スペースが混在しても、シートを開くようにしました。

①については、オープン時のオプション処理をしただけで、完全な確認がされていません。
不具合があるか調べてみてください。
③は、ダイアログを出さないようにしました。

'//
Sub ImportDataR()
'データをインポートするマクロ
　Dim FName As Variant
　Dim Bk As Workbook
　Dim ShNum As String, sh As Worksheet, shN
　Dim j As Long, i As Long, b As Boolean
　Dim msg As String
　FName = Application.GetOpenFilename("Microsoft Excel ブック,*.xls?")

　If FName = False Or FName = "" Then Exit Sub
　Set Bk = Workbooks.Open(FName, UpdateLinks:=0)
　On Error Resume Next
　Bk.Activate
msgStart:
　msg = "シート名を入れてください。"
　Do
　　ShNum = Application.InputBox(msg, "シートの選択", Type:=1 + 2 + 4)
　　If ShNum = "False" Then GoTo EndLine
　　For Each shN In Bk.Worksheets
　　 If StrComp(Trim(shN.Name), Trim(ShNum), vbTextCompare) = 0 Then
　　 'テキストコンペーアモードで、数字の揺らぎをカバーする
　　　Set sh = shN
　　　b = True
　　　Exit Do
　　 End If
　　Next
　　msg = "シート名を入れ直してください。"
　Loop
　On Error GoTo 0
　If MsgBox("Book:" & Bk.Name & vbCrLf & _
　　"Sheet:" & Bk.Worksheets(ShNum).Name & vbCrLf & _
　　"でよろしいですか？", vbOKCancel) = vbCancel Then
　　GoTo msgStart
　End If
　Set sh = Bk.Worksheets(ShNum)
　Application.ScreenUpdating = False
　ThisWorkbook.ActiveSheet.UsedRange.ClearContents
　With sh
　　For i = 1 To 21 '(A-U)
　　　j = .Cells(Rows.Count, i).End(xlUp).Row
　　　If j > 1 Then
　　　　.Range(.Cells(1, i), .Cells(j, i)).Copy ThisWorkbook.ActiveSheet.Cells(1, i)
　　　End If
　　Next
　End With
　Application.ScreenUpdating = True
　ThisWorkbook.Activate
EndLine:
　Bk.Close False
End Sub

No.2 回答者： WindFaller 回答日時： 2018/12/12 12:27

こんにちは。

>何か他に簡単なものがあればぜひご教授下さい！
今回、自分で作ったものも捨てがたいものはありますが、他の方法のほうが良いですね。
「別ブックを開けずにコピーする方法」
この表現に惹かれるし、よく出来たマクロには違いないけれども、今ひとつ、このコードにはテクニックが不足しています。

以下は、比較的よく知られた方法で、データをインポートする方法です。
最低限のエラー処理はつけました。

'//標準モジュール
Sub ImportData()
　Dim FName As Variant
　Dim Bk As Workbook
　Dim ShNum, sh As Worksheet
　Dim j As Long, i As Long
　If ThisWorkbook.ActiveSheet.UsedRange.Count > 2 Then
　　If MsgBox("受けるシートが空ではありません。削除しますか？", vbOKCancel) = vbOK Then
　　　ThisWorkbook.ActiveSheet.UsedRange.ClearContents
　　End If
　End If
　FName = Application.GetOpenFilename("Microsoft Excel ブック,*.xls?")

　If FName = False Or FName = "" Then Exit Sub
　Set Bk = Workbooks.Open(FName)
　On Error Resume Next
　Bk.Activate
msgStart:
　Do
　　ShNum = Application.InputBox("シート名またはシートIndexを入れてください。", "シートの選択", Type:=1 + 2 + 4)
　　If VarType(ShNum) = vbString Then
　　　Bk.Worksheets(ShNum).Activate
　　　If Err.Number <> 0 Then GoTo msgStart
　　ElseIf IsNumeric(ShNum) Then
　　　If ShNum = False Then GoTo EndLine
　　　If ShNum > Bk.Worksheets.Count Then MsgBox "インデックスが違います": GoTo msgStart
　　　Bk.Worksheets(CInt(ShNum)).Activate
　　　If Err.Number <> 0 Then GoTo msgStart
　　End If
　Loop Until Err.Number = 0
　On Error GoTo 0
'確認のメッセージ
　If MsgBox("Book:" & Bk.Name & vbCrLf & _
　　"Sheet:" & Bk.Worksheets(ShNum).Name & vbCrLf & _
　　"でよろしいですか？", vbOKCancel) = vbCancel Then
　　GoTo msgStart
　End If
　Set sh = Bk.Worksheets(ShNum)
　Application.ScreenUpdating = False
　With sh
　　For i = 1 To 21 '(A-U)
　　　j = .Cells(Rows.Count, i).End(xlUp).Row
　　　If j > 1 Then
　　　　.Range(.Cells(1, i), .Cells(j, i)).Copy ThisWorkbook.ActiveSheet.Cells(1, i)
　　　End If
　　Next
　End With
　Application.ScreenUpdating = True
　ThisWorkbook.Activate
EndLine:
　Bk.Close False
End Sub

No.1 回答者： WindFaller 回答日時： 2018/12/11 23:00

こんばんは。

正直なところ、こういうコードは、実用のマクロを作るというよりも、トライアルのようなコードではないかと思います。初期の頃ならともかく、今は、PCのスペックも上がったので、このままのコードだと逆に遅くなります。

こちらでチェックしたい点は、
If ExecuteExcel4Macro(Target & "R1C" & i) = "名前" Then

例えば、以下のようにするとか、
fieldname = ExecuteExcel4Macro(Target & "R1C" & i)
If fieldname <>"" Then 　　'←???
TargetCol = i

または、LIKE 演算子を使うとか、工夫が必要だと思います。
ある程度決まったフィールド名があるかと思います。

For i = 2 To 10000 ''(1)
1万行まで探すということでしょうか。
これは方法がありますが、

探すデータは数字ですか？文字ですか？
If buf = "0" Then Exit For
文字列の「0」というのは、これはよく分かりません。
探すコツは、MATCH関数を利用するのです。そのためには、きちんと文字列か数値かわけないといけません。

それと、最後が気になります。これはしなくてはならないのでしょうか？
セルに出力すれば確認できると思います。

>''配列に格納したデータの確認
>For i = 1 To UBound(GetNames)
>Debug.Print GetNames(i)
>Next i

一応、こちらでは、試して成功しましたが、こちらの思惑の中だけですので、もし、ご質問のコードをご自身で作られた方なら問題ありませんが、そうでない場合は、条件に合わせて、こちらで修正しないと、ちょっと厳しいかもしれません。今どきは、このようなコードを書く人も少ないです。