[[20160204180302]]　『表のIDを他のブックから検索し、必要情報をコピー』（がおりん）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

　

『表のIDを他のブックから検索し、必要情報をコピーしたい』（がおりん）

毎回参考にさせていただいております。 

 実際書き込むのは初めてで、うまく説明できるか…


 ブックが２つあり
 Book1同じ形式の表が沢山縦にならんでおり、日付が入力してある2行したから
   ＩＤ番号が縦に20行並んでいます。B2に日付があれば、B4～B23までID（5ケタの数字）
   が並んでいる（空欄もあります）
 Book2別のブックには、ID、氏名、購入商品（複数のセル）が横にならんでおります。
   Ｂ列にID Ｃ列に氏名　Ｄ列以降に購入商品が1セルに1品、多い一で10品程度ならんで
   います。
 Book1の日付をクリックして、マクロボタンを発動させたら、日付下のID10～20個程度を
 Book2の一覧シート内のＢ列から検索し、同じIDがあれば、ID、氏名、購入商品を
 コピーし、Book1の作業シートにペーストしたいのです。
 もし可能であれば検索で当たったIDを後からわかるように塗りつぶしなどしたいの
 ですが…マクロで可能でしょうか？
 よろしくお願いします。

＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞ 

 たとえば、以下の Macro をボタン登録。


 Sub Macro()


    Dim mySh As Worksheet
    Dim yrSh As Worksheet
    Dim c As Range
    Dim myR As Range
    Dim yrR As Range
    Dim z As Variant
    Dim cols As Long


    Application.ScreenUpdating = False


    Set mySh = ActiveSheet                              '★Book1（マクロブック）のシート
    Set yrSh = Workbooks("Book2").Sheets("Sheet1")      '★Book2 のシート
    Set c = ActiveCell
    cols = yrSh.Range("A1", yrSh.UsedRange).Columns.Count - 2   'Book2側のC列以降の使用列数


    If Not IsDate(c) Then
        MsgBox "日付欄を選んで実行してください"
        Exit Sub
    End If


    Set myR = Range(c.Offset(2), c.EntireColumn.Cells(Columns.Count).End(xlUp))
    Set yrR = yrSh.Range("B2", yrSh.Range("B" & Rows.Count).End(xlUp))


    For Each c In myR
        If Not IsEmpty(c) Then
            z = Application.Match(c, yrR, 0)
            If IsNumeric(z) Then
                c.Offset(, 1).Resize(, cols).Value = yrR.Cells(z).Offset(, 1).Resize(, cols).Value
                c.Interior.Color = vbCyan
            End If
        End If
    Next


 End Sub

（β） 2016/02/04(木) 19:03

βさん　ありがとございます。 
 え～少々難しいので、ちょっと考えさせて下さい。
 すこし動かしてみたのですが、ブックの指定とか
 自分で修正してみます。
 ところで、「Book1の作業シートにペーストしたいのです」
 の部分って入ってますか？
 すいません…解読してみます。
（がおりん） 2016/02/04(木) 20:13

 Book1の作業シート　というのがどこの、どんなシートなのかわからなかったので
 マクロボタンがある、そのシートと解釈しました。

（β） 2016/02/04(木) 20:49

βさん　ありがとございます。 
 「作業シート」すいません。表現が悪かったです。
 Book1の「作業シート」というシートにコピーしたかったです。
 （毎回1行目に貼り付けで）
 大変申し訳ありませんが、私はもっと手前の
 Book2の指定方法でつまづいています。
 少々時間がかかりますが、お待ちください。
（がおりん） 2016/02/04(木) 21:10

 >>え～少々難しいので、ちょっと考えさせて下さい。


 >>私はもっと手前の Book2の指定方法でつまづいています


 どんなところで躓いているでしょうか？


 そこを説明してもらえたら、お手伝いはできますよ。


 マクロ実行時には、Book2は、まだ読みこまれていない　とか
 Book2 と指定しているのに　インデックスエラーになってしまう　とか、
 Book2 の　シートの名前が　そのたびに変わるので、指定できない　とかとか。

（β） 2016/02/05(金) 04:07

βさん　おはようございます。 
 その通りで、インデックスエラーで、
 ｛インデックスが有効範囲にありません｝と出ます。
 ("C:\Users\がおりん\Desktop\Book2").Sheets("Sheet1")とか
 ("C:\Users\がおりん\Desktop\Book2.xlsx").Sheets("Sheet1")とか
 にしても同じエラーです。
 おそらく私のケアレスミスだと思い、何度もやり直しているのですが…
 Book名、Sheet名も間違っていないし、.xlsxも確認してます。
 もう一度一からやってみます。

（がおりん） 2016/02/05(金) 06:34 

 いろいろ試しているコードの中にファイルのパスが記述されているということは、きっと、マクロ実行時にはブックが開かれていないんでしょね。


 ブックを開かずに処理するコードもかけますが、自動的に開いて、処理して、自動的に閉じたほうが、
 がおりんさんにとってわかりやすいと思いますので以下。


 なお、ファイルパスの中の "がおりん" は、ＰＣのログインＩＤですね。これを固定で記述すると、他のＰＣで
 実行した時にフォルダが見つからないということになりますから、環境にあったものを動的に取得します。


 あわせてアップ済みのコードはIDが20以上あっても対応するようにしていましたが 20に限定しました。
 なお、Book2側はデータが2行目から存在する前提です。


 Sub Macro()


    Dim mySh As Worksheet
    Dim yrSh As Worksheet
    Dim c As Range
    Dim myR As Range
    Dim yrR As Range
    Dim z As Variant
    Dim cols As Long


    Application.ScreenUpdating = False


    Set mySh = ActiveSheet                                                                                              '★Book1（マクロブック）のシート
    Set c = ActiveCell


    If Not IsDate(c) Then
        MsgBox "日付欄を選んで実行してください"
        Exit Sub
    End If


    Set yrSh = Workbooks.Open(CreateObject("WScript.Shell").SpecialFOlders("DeskTop") & "\Book2.xlsx").Sheets("Sheet1") '★Book2 のシート


    cols = yrSh.Range("A1", yrSh.UsedRange).Columns.Count - 2   'Book2側のC列以降の使用列数


    Set myR = c.Offset(2).Resize(20)
    Set yrR = yrSh.Range("B2", yrSh.Range("B" & Rows.Count).End(xlUp))


    For Each c In myR
        If Not IsEmpty(c) Then
            z = Application.Match(c, yrR, 0)
            If IsNumeric(z) Then
                c.Offset(, 1).Resize(, cols).Value = yrR.Cells(z).Offset(, 1).Resize(, cols).Value
                c.Interior.Color = vbCyan
            End If
        End If
    Next


    yrSh.Parent.Close False


 End Sub

（β） 2016/02/05(金) 09:13

βさん。 
 無事最後までうごきました。
 ところが、間違いなく私の説明ふそくなのですが
 1.色をつけたいのは、Boob2のIDの方でした
 2.Book2の情報を貼り付けるのはBook1の「作業シート」というシートに
 ということをしたいのです。
 可能でしょうか？
 なんどもすいません。
（がおりん） 2016/02/05(金) 10:44

 >>無事最後までうごきました。


 （β） 2016/02/05(金) 09:13 のコードでOKだったと理解していいですか？


 >>2.Book2の情報を貼り付けるのはBook1の「作業シート」というシートに ということをしたいのです。


 もし、マクロボタンがあるシートが "作業シート" ならすでに、そうなっていますが、
 作業シートと、マクロボタンがあるシートとは別のシートですか？
 で、その作業シートに ID等々のデータが存在するのですか？

（β） 2016/02/05(金) 14:53

βさん 
 何度もすいません。
 作業シートはマクロぼたんがあるシートとは別シートです。
 Book1の仮に「カクロシート」のクリックした日付の下のIDを
 Book2のSheet1から検索し、検索で当たったIDとその横の氏名、購入商品に
 色を付け、Book2からコピーして
 Book1「作業シート」に貼り付ける　という感じだと思います。
 ですのでマクロボタンがあるシートは内容変更しないように
 したいのです。
 なんどもすいません。よろしくおねがいします。
（がおりん） 2016/02/05(金) 15:29
βさん 
 何かお気に触ることでも言ったでしょうか？
 私の説明が下手で、何度も同じような作業を
 させてしまったかもしれませんね。。。
 色々お世話にIなりました。
 もう少し自分で勉強して、考えてみます。
（がおりん） 2016/02/07(日) 16:45

 >>何かお気に触ることでも言ったでしょうか？


 いやいや、そんなことは全くないです。
 気を使わせてしまったようでごめんなさい。
 私用で、泊りがけの外出。今帰宅してネットを開いたところです。


 今から、レス読んで、対応します。
 しばしお待ちください。

（β） 2016/02/07(日) 17:26

 とりあえず。要件誤解あれば遠慮なく指摘してください。
 以下のコードは、作業シートの A列の1行目からマッチしたものを上詰めに転記しています。


 Sub Test()


    Dim mySh As Worksheet
    Dim yrSh As Worksheet
    Dim c As Range
    Dim myR As Range
    Dim yrR As Range
    Dim z As Variant
    Dim cols As Long
    Dim shW As Worksheet
    Dim x As Long


    Application.ScreenUpdating = False


    Set mySh = ActiveSheet                                                                                              '★Book1（マクロブック）のシート
    Set c = ActiveCell
    Set shW = Sheets("作業シート")


    If Not IsDate(c) Then
        MsgBox "日付欄を選んで実行してください"
        Exit Sub
    End If


    Set yrSh = Workbooks.Open(CreateObject("WScript.Shell").SpecialFOlders("DeskTop") & "\Book2.xlsx").Sheets("Sheet1") '★Book2 のシート


    cols = yrSh.Range("A1", yrSh.UsedRange).Columns.Count - 1    'Book2側のB列以降の使用列数


    Set myR = c.Offset(2).Resize(20)
    Set yrR = yrSh.Range("B2", yrSh.Range("B" & Rows.Count).End(xlUp))


    shW.Cells.Clear     '転記前に作業シートをクリア
    x = 1               '作業シート転記開始行番号


    For Each c In myR
        If Not IsEmpty(c) Then
            z = Application.Match(c, yrR, 0)
            If IsNumeric(z) Then
                shW.Cells(x, "A").Resize(, cols).Value = yrR.Cells(z).Resize(, cols).Value
                c.Interior.Color = vbCyan
                x = x + 1
            End If
        End If
    Next


    yrSh.Parent.Close False


    shW.Select


 End Sub

（β） 2016/02/07(日) 18:37

βさん 
 週末のお忙しいところ、ありがとうございます。
 わがままで申し訳ありませんが…2点
 1.色を付けて頂きましたが
 　色をつけるのは、book2のマッチしたIDにしたいのですが
 　可能でしょうか？
 　Book1のマクロシートの方は変更なしで。
 2.動かしてみて気づいたのですが
 　作業シートの1行目にクリックした日付を入れたいのです
 　貼り付けは2行目からとして
 浅知恵でX=2にして
 Sheets("作業シート").Range("A1").Value = c.Value
 などしてみましたが貼り付けが上手くいきませんでした。
 お手数をおかけします。よろしくお願いします

（がおりん） 2016/02/07(日) 19:50

 >>Sheets("作業シート").Range("A1").Value = c.Value


 確かに最初は日付が入った ActiveCell が c そのものなんですが、ループ処理のところで、もう c は用済みなので
 別変数を使わず、c を別の目的で使ってしまっていますので、その時点で、c には　日付が入っていないんです。


 ループの前に、セットしてやればＯＫですね。


 また、最後に　結果がわかるように、作業用シートを表示しています。
 その前に、Book2 を閉じていますので（アップ済みのコードは保存なしで閉じましたが、今回は色つけしていますから
 保存して閉じる必要があります）作業シートをSelect してもいいわけですけど、もしかしたらBook2は閉じずにそのまま残したいかもしれませんね。
 その状態で作業用シートを Select すると、エラーになります。なので、どんな状態であってもエラーなく作業用シートを表示させるために
 Application.GoTo を使いました。


 Sub Test2()


    Dim mySh As Worksheet
    Dim yrSh As Worksheet
    Dim c As Range
    Dim myR As Range
    Dim yrR As Range
    Dim z As Variant
    Dim cols As Long
    Dim shW As Worksheet
    Dim x As Long


    Application.ScreenUpdating = False


    Set mySh = ActiveSheet                                                                                              '★Book1（マクロブック）のシート
    Set c = ActiveCell
    Set shW = Sheets("作業シート")


    If Not IsDate(c) Then
        MsgBox "日付欄を選んで実行してください"
        Exit Sub
    End If


    Set yrSh = Workbooks.Open(CreateObject("WScript.Shell").SpecialFOlders("DeskTop") & "\Book2.xlsx").Sheets("Sheet1") '★Book2 のシート


    cols = yrSh.Range("A1", yrSh.UsedRange).Columns.Count - 1    'Book2側のB列以降の使用列数


    Set myR = c.Offset(2).Resize(20)
    Set yrR = yrSh.Range("B2", yrSh.Range("B" & Rows.Count).End(xlUp))


    shW.Cells.Clear     '転記前に作業シートをクリア
    x = 2               '作業シート転記開始行番号
    shW.Range("A1").Value = c.Value


    For Each c In myR
        If Not IsEmpty(c) Then
            z = Application.Match(c, yrR, 0)
            If IsNumeric(z) Then
                shW.Cells(x, "A").Resize(, cols).Value = yrR.Cells(z).Resize(, cols).Value
                yrR.Cells(z).Interior.Color = vbCyan
                x = x + 1
            End If
        End If
    Next


    yrSh.Parent.Close True          '★　もし、Book2 を閉じずに残しておきたいなら、このコードを消してください。


    Application.Goto shW.Range("A1")


 End Sub

（β） 2016/02/07(日) 21:26

βさん 
 みごとに期待通りできました！
 お忙しい中、説明下手な私に
 最後まで付き合っていただき、
 本当にありがとうございました。
（がおりん） 2016/02/08(月) 07:01
コメント返信：

[ 一覧(最新更新順) ]

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.