あのブックのあのシートに、たしかデータを入れたはず、 顧客名や住所はすでに作成してある住所録から読み込んで入力したい、など、 すでに入力したデータを再利用したい場面は結構ありますよね。
そのために、ブックを開いて、データを表示させて、セルをコピーして、こっちのブックに戻ってセルに貼り付けて‥なんてやってられない。
ボタン一発でできないものか？
そんな悩みに答えるマクロを考えてみましょう。ボタン一発はムリですが、極力手入力をしないように、マウスクリックだけで、ならできます。
マクロプログラムの手順は以下のようにしました。
１．対象のワークブックを開く →［操作］： すでに開いているブックまたは開くブックを選択
２．［操作］：ブック内のシートを選択
３．［操作］：データを選択してマウスの右ボタンをクリック
４．選択範囲をコピー
５．元のブックのカレントセルに貼付け
６．ワークブックを閉じる
操作はマウスクリックだけ。
ポイントは、別のワークブックのイベントを取得して、データをコピーすることです。
ここではマクロが設定されているワークブックから、データコピー元のワークブックでのマウスの右クリックを検出して、選択範囲のコピー・貼付けを実行しています。
詳しくはソースコードをご覧ください。
*****標準モジュール*****
Option Explicit
Public wbkTrgt As Variant
Public whtTrgt As Variant
Public actWbk As Variant
Public actWht As Variant
Public actCell As Variant
Public Sub getData()
'*****他のワークブックからデータを読み込む*****
Dim res As Variant
Dim tmp As Variant
Dim idx As Long
Dim wbkPath As Variant
Dim wbk As Workbook
Dim wbkOpened As Variant
Dim wht As Worksheet
Dim whts As Variant
Dim usedcell As Range
wbkTrgt = ""
whtTrgt = ""
'カレントセルの情報を退避
actWbk = ThisWorkbook.Name
actWht = ThisWorkbook.ActiveSheet.Name
ThisWorkbook.Activate
ThisWorkbook.Worksheets(actWht).Select
actCell = ActiveCell.Address
'イベントを無効にする
Application.EnableEvents = False
'１．ワークブックを開く すでに開いているブック/ブックを選択
'すでに開いているワークブックを探す
ReDim wbkOpened(0 To 0)
idx = -1
For Each wbk In Workbooks
If wbk.Name <> ThisWorkbook.Name Then
idx = idx + 1
If idx > UBound(wbkOpened) Then
ReDim Preserve wbkOpened(0 To idx)
End If
wbkOpened(idx) = wbk.Name
End If
Next
If idx > -1 Then
'このブック以外に開いていたら、選択リストを表示する
tmp = ""
For idx = 0 To UBound(wbkOpened)
tmp = tmp & idx + 1 & ": " & wbkOpened(idx) & vbCrLf
Next idx
tmp = tmp & "番号で入力してください‥"
res = InputBox("すでに開いているワークブックから読み込みますか？" & vbCrLf _
& tmp, "ワークブック選択", "")
If res <> "" Then
'選択したワークブックをセット
wbkTrgt = Workbooks(wbkOpened(res - 1)).Name
End If
End If
If wbkTrgt = "" Then
'選択しなかったらファイルを探す
wbkPath = Application.GetOpenFilename( _
FileFilter:="Excelファイル (*.xls), *.xls,(*.xlsx),*.xlsx", _
Title:="開きたいファイルを選択してください", MultiSelect:=False)
If wbkPath <> False And wbkPath <> "" Then
'選択したfileをセット
Workbooks.Open Filename:=wbkPath, ReadOnly:=True
wbkTrgt = ActiveWorkbook.Name
End If
End If
If wbkTrgt <> "" Then
'２．ブック内のシートを選択
ReDim whts(0 To 0)
idx = -1
For Each wht In Workbooks(wbkTrgt).Worksheets
Set usedcell = wht.Cells.SpecialCells(xlCellTypeLastCell)
'シートの中で使用済の範囲の右下のセル
' → 使用後にデータを削除しても、初期化されないことがあるが、
' → シートの中にデータがあるかどうかのいちおうの目安として使用する
If Not (usedcell Is Nothing) Then
idx = idx + 1
If idx > UBound(whts) Then
ReDim Preserve whts(0 To idx)
End If
whts(idx) = wht.Name
End If
Next
Set usedcell = Nothing
If idx > -1 Then
tmp = ""
For idx = 0 To UBound(whts)
tmp = tmp & idx + 1 & ": " & whts(idx) & vbCrLf
Next idx
tmp = tmp & "番号で入力してください‥"
res = InputBox("シートを選択してください‥" & vbCrLf _
& tmp, "シート選択", "")
If res <> "" Then
whtTrgt = whts(res - 1)
Workbooks(wbkTrgt).Worksheets(whtTrgt).Activate
MsgBox "シート上でコピーしたいセルを選択して、" & vbCrLf _
& "マウスの右ボタンでクリックしてください。" & vbCrLf _
& "現在のシートのセルに貼付けできます。", vbOKOnly, "シート選択"
End If
Else
MsgBox "このブックは空のようです‥", vbOKOnly + vbInformation
End If
End If
'イベントを有効にする
Application.EnableEvents = True
End Sub
***** ThisWorkbook *****
Option Explicit
'すべてのブックのイベントを取得するオブジェクトを宣言
' → 宣言すると、myExcel の下記のイベントが使えるようになる
Private WithEvents myExcel As Application
Private Sub myExcel_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
'すべてのブックの、右クリックイベントプロシージャ
'３．データを選択 行全体/列全体/単独セル
'４．コピー
'５．貼付け カレントセル/セル選択
If Sh.Parent.Name = wbkTrgt And Sh.Name = whtTrgt Then
'選択範囲をカレントセルに貼り付ける 値のみ
If MsgBox("選択範囲をカレントセルに貼り付けます。" & vbCrLf _
& "元には戻せません。" & vbCrLf _
& "続けますか？", vbYesNo + vbQuestion, "貼付け確認") = vbYes Then
Selection.Copy
Workbooks(actWbk).Worksheets(actWht).Range(actCell).PasteSpecial _
Paste:=xlPasteValues
Application.CutCopyMode = False
'６．ワークブックを閉じる
If wbkTrgt <> "" Then
If MsgBox("コピーしました。" & vbCrLf _
& vbCrLf _
& "読み込んだワークブック：" & wbkTrgt & vbCrLf _
& "を閉じますか？", vbYesNo + vbQuestion) = vbYes Then
Workbooks(wbkTrgt).Close savechanges:=False
End If
End If
End If
'Excelの右クリックメニュをキャンセル
Cancel = True
End If
End Sub
Private Sub myExcel_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
'選択したシート名とセルアドレスを表示
Application.StatusBar = Sh.Name & " - " & Target.Address
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'ブックを閉じる前にオブジェクトを開放
Set myExcel = Nothing
End Sub
Private Sub Workbook_Open()
'ブックが開いたらオブジェクトを取得
Set myExcel = Application
End Sub
以上。