他のエクセルから目的のデータをもってくる VBA

質問

VBAの初心者で、なかなか思うようにいきません。
とても恐縮ですが、どなたかにご指導頂きたくこちらに投稿させていただきました。
環境はExcel2010です。

ワークブック「DATA]、ワークシート名「data」にあるデータを
ワークブック「TEST」、ワークシート名「test」に張り付ける。
また、元データのワークブック名はこのマクロを行う際に選択出来るようにしたいです。

張り付けるデータは、図の
「数値2」欄に記述されている数字の行に対して
「数値１」欄の数値と、「名前」欄の（カッコ内）のローマ字のみを
エクセル名TESTに張り付けたいです。
その際「数値1」はA列、「名前」はB列にそれぞれ行の1から。

また、「数値1」欄が”0”であったり”=H10+I10”のような式の場合、
その行の「数値1」欄の値と「名前」欄の文字を
張り付けないようにしたいです。

画像のようになるのが目標です。

今現在私の考えている方法では
「数値2」を
LAST = ActiveSheet.Range("D3").End(xlDown).row
で空白セルの一つ上のセルの行数を出す。（この場合⇒7=LAST）

「数値1」欄のコピー、貼り付けを
if文でC3からLASTまで・・・・。

とここまででものマクロでさえエラーがずっと続き
コンパイルが通らず
分からないことだらけです。

言葉足らずで質問内容が分かりにくいかもしれません。
どうぞ宜しくお願い致します。

回答No.3

eden3616 · ベストアンサー

★☆★☆★☆今回のコードについて☆★☆★☆★

今回のコードで以下の点を変更・追加しました。

(1)データブックを選ぶフォームにてシートの選択機能を追加
(2)最終行の取得方法をセル"D3"より下へ終端として取得
(3)変更が容易になるようにセル指定をCellsからRangeへ変更

★☆★☆★☆ユーザーフォーム・コードの修正☆★☆★☆★

ユーザーフォームを添付画像のように作り変えます。

(1)No1で作成したユーザーフォームの下側にツールボックスより
　「リストボックス」を追加してください
(2)「ユーザーフォーム内」のコードを以下のコードと全て置き換えてください。
　（プロジェクトウィンドの『UserForm1』を右クリック→コードの表示）

'＿＿＿＿＿＿＿以下VBAコード＿＿＿＿＿＿＿＿

'■シート名一覧をリストボックスに表示
Private Sub ComboBox1_Change()
Dim i As Integer
Dim tar_book As Workbook
Dim bpath As String
Dim book_name As String
Me.ListBox1.Clear
With Me.ComboBox1
If .ListIndex > 0 Then
Set tar_book = Workbooks(.List(.ListIndex))
Me.ListBox1.AddItem "[アクティブなシート]"
For i = 1 To tar_book.Sheets.Count
Me.ListBox1.AddItem tar_book.Sheets(i).Name
Next i
Me.ListBox1.ListIndex = 0
exit_flag = exit_flag + 1
Else
bpath = Application.GetOpenFilename("ファイル *.*,*.*")
If bpath = "False" Then
exit_flag = exit_flag + 32
Exit Sub
Else
Workbooks.Open bpath
Call set_booklist
ListIndex = .ListCount - 1
exit_flag = exit_flag + 8
End If
End If
End With
End Sub

'■フォームを非表示
Private Sub CommandButton1_Click()
Me.Hide
exit_flag = exit_flag + 16
End Sub

'＿＿＿＿＿＿＿以上VBAコード＿＿＿＿＿＿＿＿

★☆★☆★☆VBAコードの差替え☆★☆★☆★

(1)標準モジュールのコードを全て以下のコードで置き換えてください。
(2)コード内の「'出力先のシートを設定」の部分をNo1同様に修正。
　（データブック及びシートの設定はフォームで指定するので、
　　ここでの設定は廃止しました）

'＿＿＿＿＿＿＿以下VBAコード＿＿＿＿＿＿＿＿

Option Explicit
'処理判定フラグ
Public exit_flag As Integer

'■メイン
Sub action()
'型宣言
Dim LAST As Long
Dim i As Long
Dim tar_obj(1) As Object
Dim cnt As Long

'フォームの表示・判定（実処理はFunction getbookで処理しています）
Set tar_obj(0) = getbook
If tar_obj(0) Is Nothing Then
MsgBox "正常に処理が出来ませんでした。" & vbCrLf & "exit_flag = " & exit_flag
GoTo exend
End If

'出力先のシートを設定
Set tar_obj(1) = Workbooks("TEST.xls").Sheets("test")

'表示先(セルA1を左上とする出力先の塊)をクリア
tar_obj(1).Range("A1").CurrentRegion.ClearContents

'メイン処理
With tar_obj(0)
'最大行数取得(セルB3から下へ終端セルの行番号)
LAST = .Range("D3").End(xlDown).Row
'データの数だけループ処理(3行目～LAST行目)
For i = 3 To LAST
'E列（数値1）が0以外なら実行
If .Range("C" & i) <> 0 Then
'E列（数式1）が数式でないなら実行
If .Range("C" & i).HasFormula = False Then
'表示先の行数をカウントアップ
cnt = cnt + 1
'A列へB列（名前）の値を表示
tar_obj(1).Range("A" & cnt).Value = getword(.Range("B" & i).Value)
'B列へC列（数値1）の値を表示
tar_obj(1).Range("B" & cnt).Value = getword(.Range("C" & i).Value)
End If
End If
Next i
End With
'終了処理・初期化
exend:
exit_flag = 0
UserForm1.Hide
Unload UserForm1
End Sub

'■カッコ「()」内の文字を取得
Function getword(word As String) As String
Dim st As Integer
Dim ed As Integer
On Error GoTo era
'変数wordから「(」の位置をstに、「)」の位置をedに代入
st = InStr(1, word, "(")
ed = InStr(st, word, ")")
'変数wordから「()」内の文字をトリムして返す
getword = Mid(word, st + 1, ed - st - 1)
Exit Function
era:
'カッコ「()」が見つからなかった場合、元の値を返す
getword = word
End Function

'■データのブックを指定
Function getbook() As Object
Dim i As Integer
Dim bpath As String
'ユーザーフォームを読込
Load UserForm1
'ユーザーフォームのコンボボックスに対する処理
With UserForm1.ComboBox1
Call set_booklist
'ユーザーフォームの表示
UserForm1.Show
'フォーム処理が正常に行われなければ中断
If exit_flag < 2 Then Set getbook = Nothing: Exit Function
'選択されているコンボボックスのブックをセット
Set getbook = Workbooks(.List(.ListIndex))
End With
'ユーザオーフォームのリストボックスに対する処理
With UserForm1.ListBox1
'リストボックスの1項目目が選択されているかで分岐
If .ListIndex = 0 Then
'アクティブシートをセットしメイン処理へ返す
Set getbook = getbook.ActiveSheet
exit_flag = exit_flag + 4
Else
'選択シートをセットしメイン処理へ返す
Set getbook = getbook.Sheets(.List(.ListIndex))
exit_flag = exit_flag + 2
End If
End With
End Function

'■ブックの一覧をコンボボックスへセット
Sub set_booklist()
Dim myData() As String
Dim i As Integer
'ワークブック格納用の配列を用意
ReDim myData(Workbooks.Count)
'ユーザーフォームのコンボボックスに対する処理
With UserForm1.ComboBox1
myData(i) = "[ファイルを指定する]"
'開いているブック名の一覧を配列へ格納
For i = 1 To Workbooks.Count
myData(i) = Workbooks(i).Name
Next i
'コンボボックスにブック名一覧をセット
.List = myData
End With
End Sub

'＿＿＿＿＿＿＿以上VBAコード＿＿＿＿＿＿＿＿

★☆★☆★☆使い方☆★☆★☆★

基本的にNo1と同じです。
フォームでコンボボックスが変更されるたびにシート名一覧がリストボックスに表示されます。
リストボックスより対象のシート名を選択して「OK」をクリックしてください。
処理結果がコード内で指定した出力先に表示されます。

お礼

ありがとうございました。
大変助かりました。
また、機会がありましたらご教授お願いいたします。

回答No.2

eden3616

>最大行数はB列ではなくD列で行うようにしました。
>LAST = .Range("D" & Rows.Count).End(xlUp).Row
>B、C、D列の行の下側には、他の数値がありまして
>End(xlUp).Rowを使うことが出来ません（>_<）
>LAST = ActiveSheet.Range("D3").End(xlDown).row
>実行時エラーに出会っている最中です。

LAST = .Range("D3").End(xlDown).Row

でいけるかと思います。
エラーの原因は、With tar_obj(0) ～ End With内の処理で
オブジェクト変数tar_obj(0)に格納したシートに対しての
「.Range("D3").End(xlDown).Row」を行っていないからです。
つまり「ActiveSheet」が余計です。（先頭のドット「.」は必要）

>現在ユーザーフォームにて
>開いているエクセルを指定していますが、
>閉じてるエクセルを指定することはできますか？

開いていないエクセルにも対応しています。
ユーザーフォームに設置したコンボボックスの1項目目に「[ファイルを指定する]」と
あるはずですので、選択して「OK」を押してください。

>それと同時にシート名も選択して呼び出すには

現在はシートを指定する処理を行っていません。
前提条件に記述しましたがシート名はデータも出力先のブックも固定（設定値）になります。
上記「[ファイルを指定する]」で開いたブックに「"data"」シートが無ければエラーになります。

>Set tar_obj(0) = Workbooks(tarbook).Sheets("tarsheet")
>のような考えでよろしいのでしょうか？

違います。
VBAにおいて基本的な事ですので、「ユーザー定義関数」の使い方、
「Workbooks」「Sheets」の「引数」については別途調べてみてください。

【tarbookについて】
ブック名を指定するフォームを表示したり、ブックを開いたりする処理を行い
最終的に指定したブックの名前を返すユーザー定義関数「tarbook」を作っています。
（コードでいうと「Function tarbook()～End Function」のコードになります）
tarbookの部分が上記処理により最終的に得られたブック名に置き換わりますので
Workbooks(ユーザー定義関数内で処理され取得されたブック名)となり、対象のブックが設定されます。

次の回答でこれらを踏まえて改良したコードを記述いたします。

参考URL：

http://www.moug.net/tech/exvba/0100042.html

回答No.1

eden3616

★☆★前提条件☆★☆
質問文から以下の条件と判断し、作成しました。
条件が違っていれば正常に動作いたしません。
(1)表示先のブック名および、シート名は定数（固定）
(2)データ取得元のブックは指定するが、シート名は定数（固定）
(3)データ取得元の行数は変動するが、フォーマットは統一である
(4)名前で使用しているカッコ「()」は1組しかない（これは想定）
(5)ご提示の参考画像でセルC8の「5」は数式により表示されたもの
　　（表示先にsample6が対象とされていないため勝手に判断）

なるべく説明コメント付で作成したつもりですが、処理内容について不明な点があればご提示ください。

★☆★実装手順☆★☆
(1)VBAコードの貼付
Alt+F11でVBEを開き新規モジュールを挿入後、最下のVBAコードを貼り付けてください
（どのブックにコードを記述しても動作いたします）

(2)対象箇所の修正
actionプロシージャ内の以下の箇所を環境に合わせて修正してください
→ tar_obj(0) がデータのブック（Function tarbookにより取得）及びシート名になります
→ （tar_obj(1) が表示先のブック及びシート名になります
-----------------------
'対象のシートを設定
Set tar_obj(0) = Workbooks(tarbook).Sheets("data")
Set tar_obj(1) = Workbooks("TEST.xls").Sheets("test")
-----------------------

(3)ユーザーフォームの作成
　表示先ブックの指定方法をどうするか考えましたが、
　フォームを作成して選ぶ様式が使いやすいかと思いましたので作成してください
　（添付画像参照）

　・挿入よりユーザーフォームを挿入
　・ツールボックスから「コンボボックス」と「コマンドボタン」を配置
　・コマントボタンのCaptionプロパティを「OK」に変更
　・ユーザーフォームを右クリックして「コードの表示」を選択するか、
　　「OK」コマンドボタンをダブルクリックしてコード画面を表示
　・以下のコードを貼付

'▼----ここから
Private Sub CommandButton1_Click()
'OKがクリックされたらユーザーフォームを非表示
Me.Hide
End Sub
'▲----ここまでのコードをユーザーフォーム内に記述

(4)VBEを終了
Alt+F11を押すか、右上の「×」でVBEを終了させる

★☆★使用方法☆★☆
使用の条件として、
(1)コードが記述されているブックが開かれている必要があります
　→　マクロを使用するのであたりまえですが
(2)表示先のブックが開かれている必要があります
　→　開かれていない場合はエラーになります

エクセルメニューの「表示→マクロ」から「action」を実行してください
開かれているブックの一覧をコンボボックスにセットしたフォームが表示されます
フォームでデータのブックを選んで「OK」をクリックしてください
データがの値を取得し、表示先のブックへ出力します

★☆★エラー未対策☆★☆
データのブックに実装手順の(2)で指定したシートが開かれていない・存在しない場合はエラーになります

★☆★VBAコード☆★☆

Option Explicit

'■メイン
Sub action()
'型宣言
Dim LAST As Long
Dim i As Long
Dim tar_obj(1) As Object
Dim tarbook As String
Dim cnt As Long

'ブック選択時のキャンセルチェック
tarbook = getbook
'ブック名が空欄なら処理を中断
If tarbook = "" Then MsgBox "キャンセルされました": Exit Sub

'対象のシートを設定
Set tar_obj(0) = Workbooks(tarbook).Sheets("data")
Set tar_obj(1) = Workbooks("TEST.xls").Sheets("test")

'表示先をクリア
tar_obj(1).Cells(1, 1).CurrentRegion.ClearContents

'メイン処理
With tar_obj(0)
LAST = .Range("B" & Rows.Count).End(xlUp).Row '最大行数
'データの数だけループ処理
For i = 3 To LAST
'C列（数値1）が0以外なら実行
If .Cells(i, 3) <> 0 Then
'C列（数式1）が数式でないなら実行
If .Cells(i, 3).HasFormula = False Then
'表示先の行数をカウントアップ
cnt = cnt + 1
'A列へB列（名前）の値を表示
tar_obj(1).Cells(cnt, 1).Value = getword(.Cells(i, 2).Value)
'B列へC列（数値1）の値を表示
tar_obj(1).Cells(cnt, 2).Value = getword(.Cells(i, 3).Value)
End If
End If
Next i
End With
End Sub

'■カッコ「()」内の文字を取得
Function getword(word As String) As String
Dim st As Integer
Dim ed As Integer
On Error GoTo era
'変数wordから「(」の位置をstに、「)」の位置をedに代入
st = InStr(1, word, "(")
ed = InStr(st, word, ")")
'変数wordから「()」内の文字をトリムして返す
getword = Mid(word, st + 1, ed - st - 1)
Exit Function
era:
'カッコ「()」が見つからなかった場合、元の値を返す
getword = word
End Function

'■データのブックを指定
Function getbook() As String
Dim i As Integer
Dim myData() As String
Dim bpath As String
'ユーザーフォームを読込
Load UserForm1
'ワークブック格納用の配列を用意
ReDim myData(Workbooks.Count)
'ユーザーフォームのコンボボックスに対する処理
With UserForm1.ComboBox1
myData(i) = "[ファイルを指定する]"
'開いているブック名の一覧を配列へ格納
For i = 1 To Workbooks.Count
myData(i) = Workbooks(i).Name
Next i
'コンボボックスにブック名一覧をセット
.list = myData
'ユーザーフォームの表示
UserForm1.Show
'コンボボックスの状態により処理分岐
'（1項目目が選択されていればTrue）
If .ListIndex = 0 Then
'ファイルダイアログを表示してブックを指定
bpath = Application.GetOpenFilename("ファイル *.*,*.*")
'ファイル指定がキャンセルされたらTrue
If bpath = False Then
'ブック名を空白として返す
getbook = ""
Else
'指定されたブックを開き、開いたブック名を返す
getbook = Workbooks.Open(Filename:=bpath).Name
End If
Else
'選択されているコンボボックスのブック名を返す
getbook = myData(.ListIndex)
End If
End With
'ユーザーフォームを閉じる
Unload UserForm1
End Function

補足

出来ました！こんなに早く回答が頂けるとは思っていなかったので、大変助かります。ありがとうございます。

最大行数はB列ではなくD列で行うようにしました。
LAST = .Range("D" & Rows.Count).End(xlUp).Row

ですが、
質問では書き忘れたのですが
B、C、D列の行の下側には、他の数値がありまして
End(xlUp).Rowを使うことが出来ません（>_<）
そのため
LAST = ActiveSheet.Range("D3").End(xlDown).row
としてD3より下へ、一番最初に空欄がある行を特定しようとしてみましたが、実行時エラーに出会っている最中です。

もう一つ知識のために知りたいのですが、
（よろしければご回答ください。）
現在ユーザーフォームにて
開いているエクセルを指定していますが、
閉じてるエクセルを指定することはできますか？

それと同時にシート名も選択して呼び出すには
Set tar_obj(0) = Workbooks(tarbook).Sheets("tarsheet")
のような考えでよろしいのでしょうか？