エクセル VBA 別のフォルダのブックからコピー

質問

Cドライブに格納されているブックのシート１のA列の内容を、Dドライブに格納されているブックのシート１のA列にコピーする場合、やはりブック名が分からなければ、ソースを書く事は不可能でしょうか。可能であれば教えていただけませんでしょうか。

※Cドライブのフォルダ名は常に変わらず、その中には一つしかブックは入っていない。

よろしくお願いします。

回答No.3

WindFaller · ベストアンサー

こんばんは。

#1の補足、了解しました。
ドライブを逆にすればよいのですね。

もう少し、すっきりしたコードにしてあげられればよいのですが、どちらか片方のファイルが開いていた場合や、コピー先のファイルがない場合などの思い当たるエラーをいくつか考慮してみました。
コードをややこしくしているのはあくまでも、エラーの発生を減らすためです。

ひとつだけ、エラー処理を施していないのは、ありえないようで、あることですが、コピー元とコピー先が同名ファイルの時があります。システムのエラーメッセージが出るはずです。

なお、読みにくいようでしたら、DST とか、SRCとかは、それぞれ、"コピー先"、"コピー元"と、文字列を置換してしまうと、少しは読みやすくなります。

なお、このような例も考えてみました。
　'1列ずつ、左の列から貼り付けていく場合
　　　'DstSht.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).PasteSpecial 'ペースト

'//
Sub Open_CopyR()
　Const SRCDRV As String = "C:\" '検索先ドライブ
　Const SRCFOLD As String = "C:\Users\(YourName)\My Documents\(TestFoler)\" '末尾に\ を入れてください
　Const DSTFILE As String = "Test1.xlsx" 'コピー先ファイル名　*このマクロファイルと同じ場所
　Dim fName As String
　Dim SrcBook As Workbook　'コピー元
　Dim DstBook As Workbook　'コピー先
　Dim DstSht As Worksheet　'コピー先シート

　On Error Resume Next
　　　Set DstBook = Workbooks(DSTFILE)　'すでに開いている場合
　If Err.Number > 0 Then　'開いていない場合
　　If Dir(DSTFILE) = "" Then MsgBox DSTFILE & " がありません。", vbCritical: Exit Sub
　　Set DstBook = Workbooks.Open(ThisWorkbook.Path & "\" & DSTFILE) 'コピー先を開く
　End If
　Set DstSht = DstBook.Worksheets("Sheet1") 'コピー先のシート
　ChDrive SRCDRV 'ドライブ変更　C:\ドライブ
　ChDir SRCFOLD 'フォルダーを開く
　fName = Application.GetOpenFilename("EXCELファイル,*.xl*") 'ファイル名取得
　If MsgBox("'" & fName & "'　でよろしいですか？", vbOKCancel, "ファイルオープン") = vbCancel Then Exit Sub
　　Set SrcBook = Workbooks(fName) 'すでに開いている場合
　If Err.Number > 0 Then '開いていない場合
　　 Set SrcBook = Workbooks.Open(fName)
　　End If
　If DstSht.Cells(Columns.Count, 1).End(xlToLeft).Column >= Columns.Count Then _
　MsgBox "これ以上コピーできません。", vbCritical: Exit Sub　'A列コピーなら不要
　SrcBook.Worksheets("Sheet1").Columns(1).Copy 'A列をコピー
　DstSht.Range("A1").PasteSpecial 'ペースト
　'1列ずつ、左の列から貼り付けていく場合
　　　'DstSht.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).PasteSpecial 'ペースト
　DstBook.Activate
　DstSht.Range("A1").Select 'ペーストの痕跡を直す
　Application.DisplayAlerts = False 'クリップボードのダイアログを出さない
　SrcBook.Close False 'コピー元を閉じる
　DstBook.Save　'コピー先保存
　DstBook.Close False 'コピー先を閉じる
　Application.DisplayAlerts = True
　Set SrcBook = Nothing
　Set DstSht = Nothing
　Set DstBook = Nothing
　ChDir "D:\"　'起動したブックのドライブに戻る
End Sub

回答No.2

WindFaller

#1の補足

Dドライブが、Removal 形式の場合、
最後の方の行で、、

　End With
　ChDrive "C:\" '←これを入れたほうが安全かもしれません。
Exit Sub
ErrorHandler:

回答No.1

WindFaller

こんにちは。

・Cドライブに格納されているブックのシート１のA列の内容を、
・Dドライブに格納されているブックのシート１のA列にコピーする
・Dドライブのブック名は決まっていない

この3つの条件で、Cドライブ側は1つ（一意）であっても、Dドライブ側は変わるという条件でよろしいのでしょうか。

マクロの起動は、別のファイルから、と理解してよろしいのでしょうか？
そうすると、Dドライブ側は、対話型で開くしかないと思います。

ちょっとごちゃごちゃしていますが、ステップモード(F8)で追いかけてみてください。

'//
Sub Open_Copy()
　Const DSTDRV As String = "D:\" 'コピー先ドライブ
　Const SRCFOLD As String = "C:\Users\(YourName)\My Documents\(SpecialName)\" '末尾に\ を入れてください
　Const SRCFILE As String = "Test1.xlsx" 'ソースファイル名
　Dim fName As String
　Dim SrcBook As Workbook
　On Error GoTo ErrorHandler
　On Error Resume Next
　Workbooks(SRCFILE).Activate
　If Err.Number > 0 Then
　　Workbooks.Open SRCFOLD & SRCFILE
　End If
　Set SrcBook = ActiveWorkbook
　On Error GoTo 0
　ChDrive DSTDRV 'ドライブ変更

　'対話型ダイアログボックス
　fName = Application.GetOpenFilename("EXCELファイル,*.xl*") 'ファイル名取得
　If MsgBox("'" & fName & "'　でよろしいですか？", vbOKCancel) = vbCancel Then Exit Sub
　With Workbooks.Open(fName)
　　SrcBook.Worksheets("Sheet1").Columns(1).Copy 'A列(縦）をコピー
　　.Worksheets("Sheet1").Range("A1").PasteSpecial 'ペースト
　　.Worksheets("Sheet1").Range("A1").Select 'ペーストの痕跡を直す

　　Application.DisplayAlerts = False 'クリップボードのダイアログを出さない
　　　 SrcBook.Close False 'コピー元を閉じる
　　　 .Save
　　　 .Close False
　　Application.DisplayAlerts = True
　End With
　Exit Sub
ErrorHandler:
　'ドライブが用意されていない時のエラーメッセージ
　If Err.Number = 68 Then
　　MsgBox Err.Description, vbCritical
　End If
End Sub

補足

＞マクロの起動は、別のファイルから、と理解してよろしいのでしょうか？

ご回答、ありがとうございます。

正しくは下記です、本当に申しわけありません。

・Cドライブに格納されているブックのシート１のA列の内容を、
・Dドライブに格納されているブックのシート１のA列にコピーする
・Cドライブのブック名は決まっていない、Dドライブのファイル名は固定です。

さらに、

・Dドライブからマクロは実行します。