Excel2003重複しないデータを別のシートに

Question

お世話になります。Excel初心者です。皆様のお知恵をお貸しいただければ幸いです。
Excel2003で下記の件で、非常に困っております。

※皆様、申し訳ございません。ベストアンサーを選択すると質問が締め切られることを
　　知らなかった為、再度質問させて頂きたくよろしくお願いいたします。

sheet1に重複しないデータがあります。

A B C　←セル横
1 顧客No 商品No パーツNo
 2 12345 23-1111 23
 3 13456 21-1234 55
 4 23456 22-5555 66

sheet2に上記のどの情報を入れても、3つのデータを表示させたいです。

Dセル
3行目 顧客No 
4行目 商品No　→ここに入力(21-1234)
5行目 パーツNo

上記の縦の列は空白です。sheet1の2の商品No21-1234と入力すると
sheet1の顧客No13456とパーツNo55が表示されます。
 同様にsheet2のパーツNo空白欄にsheet1のパーツNoの55と入力
すると、sheet2の顧客Noと商品Noが表示されます。

こういう事は、Excel2003で可能なのでしょうか。
VBAで実施しようかと思っておりますが、ど素人ですので、お手数ですが
なるべくコードのコメントを入れて頂けると幸いです。
お手数お掛けしますが、ご教授よろしくお願いいたします。

eden3616 · Accepted Answer

No9の回答文を読み返していたら間違いがありましたので訂正いたします。
VBAコード手前の入力時条件による処理内容説明になります。

(1)もし表示させるだけのセル（D6～G9）に値が入力された場合
　→　入力不可のメッセージを表示し、入力前のデータを再表示する

↓

(1)もし表示させるだけのセル（D6～D9）に値が入力された場合
　→　入力不可のメッセージを表示し、入力前のデータを再表示する

eden3616 · Answer

最下のVBAコードと差し換えてください。

>私の勘違いと言いますがミスがありまして、sheet1のDATAは、(AからAKまで)です。
>AIではなかったです。。。すみません。
>Sheet2のD列は、3行目から17行目まで表示させてたいです。

対応する形で添付画像の様式に変更しました。ご確認ください。

>10行目から17行目は、空欄があるときがあります。空欄列は、飛ばして表示させます

空欄は入力時ではなく表示のときに取得列（表示は行）を飛ばして表示させるということですね。
この場合の処理ですが以下の用途が考えられます（現在は(2)の処理で動作致します）。
(1)処理を飛ばす → 前回の表示が残ったまま
(2)処理は行う → 空欄であれば空欄のセルが表示される

＞ドロップダウンリストは、Sheet2のG列14行目と20行目に文字
＞(例：有効とか無効)(例：あり、なし)
＞みたいな言葉が入力されます。空欄もありえますが、無視して構いません。

上記同様に用途により処理が変わります。
（現在は(2)の処理で動作致します）

>(Sheet1のA列、B列、C列そのままの機能で)4行目から9行目までは、表示。

Sheet1のA、B、C列をSheet2のD3、D4、D5に表示し、
Sheet1のD、E、F、G列をSheet2のD6、D7、D8、D9に表示するのであれば
『4行目から9行目』ではなく『3行目から9行目』ですよね？

>10行目(Sheet1のH列)から17行目(Sheet1のO列)表示、編集(Sheet1へ保存)
＞そしてSheet2のG列の表示、編集できるせるは、Sheet1のP列からAK列までを。

この場合以下の状態が想定されますので、対応する形で処理を行っています。
(1)もし表示させるだけのセル（D6～G9）に値が入力された場合
　→　入力不可のメッセージを表示し、入力前のデータを再表示する
(2)変更対象のセルD10～D17及びG3～G24に値が入力された場合
　→　検索された行の対応されたH～O列及びP～AK列のセルを更新
(3)D3～D5で検索した結果、見つからなかった場合に値が入力された場合
　→　見つからないメッセージを表示し、『不明』と表示させる

■VBAコード

'ワークシート内のセルに変更があった場合自動実行されます
'　→　変更されたセルがRange変数「Target」に代入されています
Private Sub Worksheet_Change(ByVal Target As Range)

'使用する変数の型を宣言(定義)
Dim myRng As Variant, mySt As Worksheet, tar As Range, i As Integer
Dim j As Integer
'変更されたセルの数が10個より大きい場合は終了
If Target.Count > 10 Then Exit Sub

'対象とするシートをオブジェクト変数へセット
Set mySt = Worksheets("Sheet1")

'変数Targetのセルを順次、変数myRngに格納しながら
'For～Next間をセルの数だけ繰り返し処理
For Each myRng In Target
　'With～End Withまでの省略した場合のオブジェクト(ここではSheet1)を指定
　With mySt

　　'▼対象とするセルがセル範囲(D3:D5)内であれば処理
　　If Not Application.Intersect(myRng, Range("D3:D5")) Is Nothing Then
　　　'変更されたセルの値でSheet1(の対象列)を検索して変数tarへ格納
　　　Set tar = .Columns(myRng.Row - 2).Find(myRng.Value, , xlValues, _
　　　　　xlWhole, xlByRows, xlPrevious, True, True, False)
　　　'変更されたセルの行番号を変数iに格納
　　　i = myRng.Row
　　　'イベントを無効
　　　'(セル内容の変更で自分自身が再度実行されないように無効化)
　　　Application.EnableEvents = False
　　　'Do～Loop間を繰り返し処理
　　　Do
　　　　'変数iに1を加算、iが6になれば3に変更
　　　　i = i + 1: If i = 6 Then i = 3
　　　　'iが変更された行番号になればループから抜ける
　　　　If i = myRng.Row Then Exit Do
　　　　'検索結果によって出力結果を分岐
　　　　If tar Is Nothing Then
　　　　　'検索結果が見つからなければ不明を出力
　　　　　Cells(i, "D") = "不明"
　　　　Else
　　　　　'見つかったセルと同じ行の対象項目の値を出力
　　　　　Cells(i, "D") = .Cells(tar.Row, i - 2).Value
　　　　End If
　　　Loop
　　　'D列の6～17行目にSheet1(D～O列)のデータを出力
　　　'G列の3～24行目にSheet1(P～AK列)のデータを出力
　　　For j = 3 To 24
　　　　If tar Is Nothing Then
　　　　　If 6 <= j And j <= 17 Then Cells(j, "D") = "不明"
　　　　　Cells(j, "G") = "不明"
　　　　Else
　　　　　If 6 <= j And j <= 17 Then _
　　　　　　　Cells(j, "D") = .Cells(tar.Row, "D").Offset(0, j - 6).Value
　　　　　Cells(j, "G") = .Cells(tar.Row, "P").Offset(0, j - 3).Value
　　　　End If
　　　Next j
　　　'イベントを再開
　　　Application.EnableEvents = True

　　'▼対象とするセルがセル範囲(D6:D17又はG3:G24)内であれば処理
　　ElseIf (Not Application.Intersect(myRng, Range("D6:D17")) Is Nothing) _
　　　　Or (Not Application.Intersect(myRng, Range("G3:G24")) Is Nothing) Then
　　　'検索セルtarが無い場合は検索
　　　If tar Is Nothing Then
　　　　Set tar = .Columns("A").Find(Range("D3").Value, , xlValues, _
　　　　　　xlWhole, xlByRows, xlPrevious, True, True, False)
　　　End If
　　　'対象とするセルが変更可能のセル範囲であるかの判定
　　　Application.EnableEvents = False
　　　'▼対象とするセルがセル範囲(D6:D9)内であれば処理
　　　If Not Application.Intersect(myRng, Range("D6:D9")) Is Nothing Then
　　　　'検索セルが見つからなければ不明、見つかれば値を戻して表示
　　　　If tar Is Nothing Then
　　　　　myRng.Value = "不明"
　　　　Else
　　　　　myRng.Value = .Cells(tar.Row, "D").Offset(0, myRng.Row - 6).Value
　　　　End If
　　　　'変更不可のメッセージを表示
　　　　MsgBox "対象のセル""" & myRng.Address(False, False) & """は変更できません"
　　　'▼対象とするセルがセル範囲(D10:D17)内であれば処理
　　　Else
　　　　'検索セルが見つからなければメッセージを表示
　　　　If tar Is Nothing Then
　　　　　myRng.Value = "不明"
　　　　　MsgBox "対象のセルが不明です"
　　　　'検索セルが見つかればSheet1の範囲D～AKで該当項目の検索行を入力値で更新
　　　　Else
　　　　　Select Case myRng.Column
　　　　　　Case 4　'D列(列番号4)が入力された場合
　　　　　　　.Cells(tar.Row, "H").Offset(0, myRng.Row - 10) = myRng.Value
　　　　　　Case 7　'G列(列番号7)が入力された場合
　　　　　　　.Cells(tar.Row, "P").Offset(0, myRng.Row - 3) = myRng.Value
　　　　　End Select
　　　　End If
　　　End If
　　　Application.EnableEvents = True
　　End If

　End With
Next
End Sub

eden3616 · Answer

No6の捕捉について確認したい事柄がございます。

ご提示の状況が文面だけですので、こちらで実際に再現した際に矛盾が発生致しました。
そのため一旦様式の状態を確認させて頂きたいと思います。

こちらの解釈により想定したSheet2の様式を添付画像に致します
捕捉コメントより実際に解釈した内容は以下の通りです。
ご確認お願いします。

>Sheet1のD列(値の表示)は、3行目から15行目まで

ここの解釈が非常に不安です・・・
最初のSheet1はSheet2の誤りであり、
Sheet2に検索結果を表示させるD列は3～15行目であるということでしょうか？

>Sheet2の(入力するシート)は、D列が3行目から15行目です。
>Sheet1のデータM列です。

そのうちのD3～D5はSheet1のA～B列で、
D6～D15はSheet1のD～M列を表示させるという事でしょうか？

>(Sheet1のA列、B列、C列)4行目から9行目までは、表示←これは、できました。
>※sheet2のD列3行目から5行目までは、そのままで構いません。
>簡単に申し上げますと、sheet1のデータは、A列からAIまでございます。

Sheet2のD3～D5入力による顧客、商品、パーツNoの検索結果表示のことだと思うのですが、
Sheet1のA4～C9範囲に上記3種のNoが入っていると解釈いたします。
A～AIにデータが入っているという事ですので、上記解釈と合わせますと
Sheet1のデータはA4～AI9の範囲であるということでしょうか？
実質処理においてはSheet1に何行のデータがあっても動作するかと思います。

>10行目から15行目は、表示、編集(Sheet1へ保存)
>10行目から15行目までは、空欄があるときがあります。空欄列は、飛ばして表示させます

「Sheet1へ保存」とあることから、Sheet2の事だと思うのですが、
Sheet2のD10～D15(6行分)に表示するデータはSheet1のどの列範囲になりますか？
残り使用されていないSheet1の列は「D～M列の10列分」であり、
表示させるSheet2のD列は「6～15行の10行分」であることから、

Sheet1の検索された行のD～M列を、Sheet2の6～15行に表示させ、
そのうち・・・Sheet2のD10～D15が変更された場合は
Sheet1のH～M列を更新させるという解釈であっていますか？

>Sheet2のG列でしたがSheet1のN行からAIまでを表示。
>ドロップダウンリストは、Sheet2のG列　14行目と20行目に文字(例：有効とか無効)(例：あり、なし)
>みたいな言葉が入力されます。空欄もありえますが、無視して構いません。

Sheet2のG3～G24に入力された場合においても
Sheet1の検索行のN～AI列を更新させるのでしょうか？
プルダウンで選ぶという事は表示したセルを変更するということですので、
変更をSheet1に反映（更新）させるという解釈とします。

>※ドロップダウンメニューは、Sheet1でいうと、AA(Sheet2のG列の14行目)AG(Sheet2のG列の20行目)です。
>sheet2のG列は、3行目から24行目です。
>Sheet1のNからAIになります。

Sheet2の3～24行目にSheet1のN～AI列を表示するのであれば、
Sheet2のG14はY列、G20はAE列になるかと。

Ｎ(3),Ｏ(4),Ｐ(5),Ｑ(6),Ｒ(7),Ｓ(8),Ｔ(9)
Ｕ(10),Ｖ(11),Ｗ(12),Ｘ(13),Ｙ(14) ← プルダウン
Ｚ(15),AA(16),AB(17),AC(18),AD(19),AE(20) ← プルダウン
AF(21),AG(22),AH(23),AI(24)

>＞'変更されたセルの数が10個より大きい場合は終了
>＞If Target.Count > 10 Then Exit Sub
>上記の変更されたセルの数とは、どこのセルでしょうか。
>どうしても分かりませんでした。すみません。。。

Sheet2のD3～D5セルが変更された場合にSheet1から検索して表示する処理が行われます。
この時の変更されたセルとはD3～D5セル(顧客、商品、パーツNo)のことで、
商品Noを入力した場合は変更したセルはD4となります。

コピー貼付などで他のセルまたはクリップボード等からD3～D5を含むセル範囲に値が張り付けられた場合、
貼り付け(変更)された全てのセルに対して順に処理が行われます。
例えばD4～D6セルにデータが張り付けられた場合、以下の流れで処理されます。
(1)D4の処理：商品Noで検索→検索結果を他の項目(D3、D5)へ表示
(2)D5の処理：パーツNoで検索→検索結果を他の項目(D3、D4)へ表示
(3)D6の処理：D3～D5のセル範囲ではないため、検索処理は行われません

この場合、(1)で表示された結果が(2)の結果で上書きされますので、結果的に(2)の結果が表示されます。
この処理の意味はD3～D5(縦方向の範囲)への一括貼付けでは意味を持ちませんが、
D3～E3など横方向の範囲で張り付けられた場合でも動作するように、このような方法をとっております。
先の回答で書きましたが、入力(変更)される値が1個のみであればこの処理は不要になります。

tom04 · Answer

No.2・3です。

補足を読ませていただきました。
結局↓の画像のようになっていて、

（1）Sheet1のデータのD3～D5セルに表示されている行のD～AI列をG3以降に表示
（2）Sheet2のG列データ変更があればSheet1に反映したい。
という解釈でよい訳ですね？

前回のコードはすべて消去し、Sheet2のシートモジュールに↓のコードをコピー＆ペーストしてみてください。

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim c As Range, r As Range, wS As Worksheet
 Set wS = Worksheets("Sheet1")
    If Intersect(Target, Range("D3:D5,G3:G34")) Is Nothing Or Target.Count > 1 Then Exit Sub
    With Target
        If .Value <> "" Then
            If .Column = 4 Then
                Set c = wS.Columns(.Row - 2).Find(what:=.Value, LookIn:=xlValues, lookat:=xlWhole)
                    If Not c Is Nothing Then
                        Application.EnableEvents = False
                            With Range("D3")
                                .Value = wS.Cells(c.Row, "A")
                                .Offset(1) = wS.Cells(c.Row, "B")
                                .Offset(2) = wS.Cells(c.Row, "C")
                            End With
                        Application.EnableEvents = True
                        Set r = wS.Range("A:C").Find(what:=.Value, LookIn:=xlValues, lookat:=xlWhole)
                            wS.Cells(r.Row, "D").Resize(, 32).Copy
                            Range("G3").PasteSpecial Paste:=xlPasteValues, Transpose:=True
                        .Select
                    Else
                        If MsgBox("該当データがありません" & vbCrLf & "再入力しますか？", vbYesNo) = vbYes Then
                            Range("D3").Resize(3).ClearContents
                            .Select
                        Else
                            Exit Sub
                        End If
                    End If
            Else
                Set r = wS.Range("A:A").Find(what:=Range("D3"), LookIn:=xlValues, lookat:=xlWhole)
                    wS.Cells(r.Row, .Row + 1) = .Value
            End If
        End If
 End With
 End Sub

今度はどうでしょうか？m(_ _)m

eden3616 · Answer

No5のコードの修正になります。
度々失礼いたします。

>sheet2のG列には、空欄もありえます。空欄は、無視します。

空欄の場合無視する処理を入れておりませんでしたので訂正たします。
この「空欄の場合無視をする動作」についてですが、

(1)G列に表示後に修正した値でSheet1に反映する際に
　空欄であれば無視をする
(2)D列に入力後にSheet1のD～AI列のデータが空欄であれば
　無視して詰めてG列に表示する

のかが提示されていませんので判断しかねます。
(1)の場合の修正であれば、コード中ほどにあります以下の箇所を変更願います。

'▼対象とするセルがセル範囲(G3:G34)内であれば処理
　　ElseIf Not Application.Intersect(myRng, Range("G3:G34")) Is Nothing Then

↓

'▼対象とするセルがセル範囲(G3:G34)内であれば処理
　　ElseIf (Not Application.Intersect(myRng, Range("G3:G34")) Is Nothing) And (Len(myRng) > 0) Then

(2)の場合の修正であれば、データを変更後に反映させる際に詰めて表示されたG列からだと
　元のD～AI列のどこへ反映させるか分からなくなりますので別途作業列（H列など）に
　取得時の列番号を書出す等の追加処理が必要になります。
　ですが、14、20行目に入力規制を設けられているのであれば、この可能性は少なそうなので
　今回修正コードは提示致しません。
　もし、(2)の場合の修正が必要であれば再度補足願います。

eden3616 · Answer

No4です。

■この質問における追加処理について

No2のtom04様への捕捉コメントにおいて自分なりに考えた仕様で作成しました。
ので追加回答致します。
最下のVBAコードで差替えて使用してください。

>ただ、実はこの先にも続きがありまして、Sheet1のDからAIでのデータがあるとします。
>そして、同じSheet2のG列の3行目から24行目までのデータを表示させるというものです。

Sheet1のD～AI列32列分と、3行～24行の22行分の数が一致しないため、関連性が見えません。
前後の文面から「3行目から24行目」ではなく「3行目から34行目」の入力間違いではと解釈致します。

>しかも、Sheet2の14行目と20行目には、プルダウンメニューになっております。

プルダウン(ドロップダウン)リストの仕様は完全に想定でしかありませんが、14行目（O列のデータが入る行）と
20行目（U列のデータが入る行）において入力規則の下記設定が行われているものと想定します。

【設定】タブ
入力値の種類：リスト　　　　　　 ☑空白を無視する
▼14行目の場合　　　　　　　　　☑ドロップダウンリストから選択する
元の値：=Sheet1!O$2:O$100
▼20行目の場合
元の値：=Sheet1!U$2:U$100
【入力時メッセージ】タブ：OFF
【エラーメッセージ】タブ：OFF

>また、sheet2のG列には、空欄もありえます。空欄は、無視します。またG列に表示したデータを編集すると
>Sheet1のD列以降に保存(編集？)されるという仕様になります。

上記解釈により・・・（この解釈が異なっていれば補足願います）
D3～D5セルの入力時にD～AI列の32列分のデータも一緒にSheet2のG3～G34セルへ書き出し
Sheet2のG3～G34が変更された場合は、対応する行のSheet1のD～AI列を変更する処理としています。

>これを一つのシート上で可能なのでしょうか？
>今日、会社で色々調べてみましたが、同じような事例が全くヒットしませんでした。。。

これぐらい複雑化された処理において、事例全体での一致があれば奇跡と呼べるのではないでしょうか。
このような場合は複合化処理のうち、各処理におけるパーツを組み合わせて目的を達成します。
・VBA（マクロ）の登録・作成方法
・セル入力時のマクロ実行方法
・マクロでのセル検索方法
　　　　etc・・・

■VBAコード

'ワークシート内のセルに変更があった場合自動実行されます
'　→　変更されたセルがRange変数「Target」に代入されています
Private Sub Worksheet_Change(ByVal Target As Range)

'使用する変数の型を宣言（定義）
Dim myRng As Variant, mySt As Worksheet, tar As Range, i As Integer
Dim j As Integer
'変更されたセルの数が10個より大きい場合は終了
If Target.Count > 10 Then Exit Sub

'対象とするシートをオブジェクト変数へセット
Set mySt = Worksheets("Sheet1") '★

'変数Targetのセルを順次、変数myRngに格納しながら
'For～Next間をセルの数だけ繰り返し処理
For Each myRng In Target
'With～End Withまでの省略した場合のオブジェクト(ここではSheet1)を指定
　　With mySt

'▼対象とするセルがセル範囲(D3:D5)内であれば処理
　　　　If Not Application.Intersect(myRng, Range("D3:D5")) Is Nothing Then
　　　　　　'変更されたセルの値でSheet1(の対象列)を検索して変数tarへ格納
　　　　　　Set tar = .Columns(myRng.Row - 2).Find(myRng.Value, , xlValues, _
　　　　　　　　　　xlWhole, xlByRows, xlPrevious, True, True, False) '◎
　　　　　　'変更されたセルの行番号を変数iに格納
　　　　　　i = myRng.Row
　　　　　　'イベントを無効
　　　　　　'(セル内容の変更で自分自身が再度実行されないように無効化)
　　　　　　Application.EnableEvents = False
　　　　　　'Do～Loop間を繰り返し処理
　　　　　　Do
　　　　　　　　'変数iに1を加算、iが6になれば3に変更
　　　　　　　　i = i + 1: If i = 6 Then i = 3
　　　　　　　　'iが変更された行番号になればループから抜ける
　　　　　　　　If i = myRng.Row Then Exit Do
　　　　　　　　'検索結果によって出力結果を分岐
　　　　　　　　If tar Is Nothing Then
　　　　　　　　　　'検索結果が見つからなければ不明を出力
　　　　　　　　　　Cells(i, "D") = "不明" '☆
　　　　　　　　Else
　　　　　　　　　　'見つかったセルと同じ行の対象項目の値を出力
　　　　　　　　　　Cells(i, "D") = .Cells(tar.Row, i - 2).Value '◎
　　　　　　　　End If
　　　　　　Loop
　　　　　　'G列の3～34行目にデータを出力
　　　　　　For j = 1 To 32
　　　　　　　　If tar Is Nothing Then
　　　　　　　　　　Cells(j + 2, "G") = "不明"
　　　　　　　　Else
　　　　　　　　　　Cells(j + 2, "G") = .Cells(tar.Row, "D").Offset(0, j - 1).Value
　　　　　　　　End If
　　　　　　Next j
　　　　　　'イベントを再開
　　　　　　Application.EnableEvents = True
　　　　　　
　　　　'▼対象とするセルがセル範囲(G3:G34)内であれば処理
　　　　ElseIf Not Application.Intersect(myRng, Range("G3:G34")) Is Nothing Then
　　　　　　'検索セルtarが無い場合は検索
　　　　　　If tar Is Nothing Then
　　　　　　　　Set tar = .Columns("A").Find(Range("D3").Value, , xlValues, _
　　　　　　　　　　xlWhole, xlByRows, xlPrevious, True, True, False) '◎
　　　　　　End If
　　　　　　'検索セルが見つからなければメッセージを表示して終了
　　　　　　If tar Is Nothing Then
　　　　　　　　MsgBox "対象のセルが不明です" & vbCrLf & "終了します"
　　　　　　　　Exit Sub
　　　　　　'検索セルが見つかればSheet1の範囲D～AIで該当項目の検索行を入力値で更新
　　　　　　Else
　　　　　　　　Application.EnableEvents = False
　　　　　　　　.Cells(tar.Row, "D").Offset(0, myRng.Row - 3) = myRng.Value
　　　　　　　　Application.EnableEvents = True
　　　　　　End If
　　　　End If

End With
Next
End Sub

eden3616 · Answer

下記質問でのNo8に対するコメントへの回答になります。

http://oshiete.goo.ne.jp/qa/8798457.html

>また、同じ件名で質問をさせて頂いております。
>今回のコードの下にでも、何をしているコードなのかも
>頂けると幸いです。

再度回答のためお邪魔致します。

■処理の流れ

変更されたセルに対して以下の①～⑤の処理を行っています
　→　変更されたセルとは、セルの値に変化があったセルのことで
　　　入力による変更以外にコピー貼付などでも実行されます

①変更されたセルが範囲内であれば②へ
　　↓
　　②変更された値で対象シート(Sheet1)を検索
　　↓
　　③顧客→商品→パーツ→顧客…の順で④～⑤を繰り返し処理
　　↓
　→④変更されたセルが商品であれば、次の項目(パーツ)に対して処理
↑　｜　処理対象の項目が変更されたセルの項目になれば繰り返しを終了
｜　↓
｜　⑤変更されたセルが商品であれば、結果を表示させるパーツのセルに
｜　｜　②で検索されたセルのパーツ列の値を出力
｜　↓
　←
　
コードの具体的な意味はコード内にコメントを追加しております。

■補足
本来1つのセルが変更されるのであればFor～Loopにおいて
全ての変更したセルに対し処理を行う必要がありません。

変更された全セルを対象としている理由は実際の変更対象とする
セル範囲D3～D5を含むD3～E5などにコピー貼付けされた場合に
おいても該当セルD3～D5に対して処理を行うようにしています。

If Target.Count > 10 Then Exit Sub

上記のコードで変更されたセルが10個以上の場合は処理を行わずに
終了しているのは、D列全てにコピー貼付が行われた場合など
処理が膨大になることを防ぐために終了させています。

■VBAコード

'ワークシート内のセルに変更があった場合自動実行されます
'　→　変更されたセルがRange変数「Target」に代入されています
Private Sub Worksheet_Change(ByVal Target As Range)

'使用する変数の型を宣言（定義）
Dim myRng As Variant, mySt As Worksheet, tar As Range, i As Integer

'変更されたセルの数が10個より大きい場合は終了
If Target.Count > 10 Then Exit Sub

'対象とするシートをオブジェクト変数へセット
Set mySt = Worksheets("Sheet1") '★

'変数Targetのセルを順次、変数myRngに格納しながら
'For～Next間をセルの数だけ繰り返し処理
For Each myRng In Target
'With～End Withまでの省略した場合のオブジェクト(ここではSheet1)を指定
　　With mySt

'対象とするセルがセル範囲(D3:D5)内であれば処理
　　　　If Not Application.Intersect(myRng, Range("D3:D5")) Is Nothing Then

'変更されたセルの値でSheet1(の対象列)を検索して変数tarへ格納
　　　　　　Set tar = .Columns(myRng.Row - 2).Find(myRng.Value, , xlValues, _
　　　　　　　　　　xlWhole, xlByRows, xlPrevious, True, True, False) '◎

'変更されたセルの行番号を変数iに格納
　　　　　　i = myRng.Row

'イベントを無効
　　　　　　'(セル内容の変更で自分自身が再度実行されないように無効化)
　　　　　　Application.EnableEvents = False

'Do～Loop間を繰り返し処理
　　　　　　Do
　　　　　　　　'変数iに1を加算、iが6になれば3に変更
　　　　　　　　i = i + 1: If i = 6 Then i = 3

'iが変更された行番号になればループから抜ける
　　　　　　　　If i = myRng.Row Then Exit Do

'検索結果によって出力結果を分岐
　　　　　　　　If tar Is Nothing Then
　　　　　　　　　　'検索結果が見つからなければ不明を出力
　　　　　　　　　　Cells(i, "D") = "不明" '☆
　　　　　　　　Else
　　　　　　　　　　'見つかったセルと同じ行の対象項目の値を出力
　　　　　　　　　　Cells(i, "D") = .Cells(tar.Row, i - 2).Value '◎
　　　　　　　　End If
　　　　　　Loop

'イベントを再開
　　　　　　Application.EnableEvents = True
　　　　End If

End With
Next
End Sub

tom04 · Answer

こんばんは！

補足の文章を何度も読み返してみましたが、何をどうしたいのか判りません。

＞DからAIでのデータがあるとします
と
＞同じSheet2のG列の3行目から24行目までのデータを表示させるというものです
はつながっているのでしょうか？
もしそうであれば、列数と行数が違いますので、どこのデータをどこのセルに・・・
というように具体的な表現でないと、こちらではお手元のSheetのレイアウトが全く判らないので
回答のしようもありません。

＞しかも、Sheet2の14行目と20行目には、プルダウンメニューになっております。
＞また、sheet2のG列には、空欄もありえます。空欄は、無視します。またG列に表示したデータを編集すると
＞Sheet1のD列以降に保存(編集？)されるという仕様になります。
＞これを一つのシート上で可能なのでしょうか？

に関してもおそらく最初の文章とつながっているのでしょうが、
Sheet2のG3～G24セルの空白以外のセルをSheet1のD列以降に表示したいのか？
もしそうであれば何行目に表示するのか？等々・・・
判らないコトだらけです。

この辺が判らないと関数、もしくはマクロにしても全く意味のないものになってしまいますので、
ココで曖昧なまま回答をするのは無意味だと思います。
他の方が読めば理解できるのかもしれませんが・・・

当方の読解力がなくてごめんなさいね。m(_ _)m

tom04 · Answer

No.1です。

＞Sheet1の値は、罫線がないので、Sheet2の罫線が
消えてしまいます。

そうですね！
前回はそのままコピー＆ペーストにしていましたので、
「値」の貼り付けにすれば良いと思いました。

しかし、
＞Sheet2の方に例えば、パーツNoを入力すると
＞正しいデータを拾って顧客Noと商品Noが表示されます。
＞パーツNoを入力→正しい値が表示される。そのパーツNoのセルで
＞Enterキーを押下すると、右側に値が表示されてしまいます。
＞これも、直そうかとしましが、何故か分かりませんでした
の部分が改善されませんので、もう一度コードを変更してみました。

前回のコードはすべて消去して↓のコードにしてみてください。
尚、各Sheetの配置は前回通りとします。

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range, wS As Worksheet
    Set wS = Worksheets("Sheet1")
    If Intersect(Target, Range("E3:E5")) Is Nothing Or Target.Count > 1 Then Exit Sub
        With Target
            If .Value <> "" Then    '★←追加してみました。
                Set c = wS.Columns(.Row - 2).Find(what:=.Value, LookIn:=xlValues, lookat:=xlWhole)
                    If Not c Is Nothing Then
                        Application.EnableEvents = False    '★ここから変更
                            With Range("E3")
                                .Value = wS.Cells(c.Row, "A")
                                .Offset(1) = wS.Cells(c.Row, "B")
                                .Offset(2) = wS.Cells(c.Row, "C")
                            End With
                            .Select
                        Application.EnableEvents = True '★ここまで
                    Else
                        If MsgBox("該当データがありません" & vbCrLf & "再入力しますか？", vbYesNo) = vbYes Then
                            Range("E3").Resize(3).ClearContents
                            .Select
                        Else
                            Exit Sub
                        End If
                    End If
            End If
        End With
 End Sub

こんどはどうでしょうか？m(_ _)m

tom04 · Answer

こんばんは！
↓のサイトの関連質問ですね。

http://oshiete.goo.ne.jp/qa/8798457.html

＞なるべくコードのコメントを入れて頂けると幸いです。
というコトですので、コメントを入れてみました。
前回のコードより変えています。
尚、Sheetの配置は↓の画像のように左側がSheet1・右側がSheet2とします。

Sheet2のSheetモジュールですので
Sheet見出しの「Sheet2」上で右クリック　→　コードの表示　→　VBE画面のカーソルが点滅しているところに
↓のコードをコピー＆ペースト　→　Sheet2のExcel画面に戻りE3～E5セルにデータを入力してみてください。

Private Sub Worksheet_Change(ByVal Target As Range) 'この行から
    '▼変数の宣言
    Dim c As Range, wS As Worksheet
    '▼Sheet1を変数「wS」に格納
    Set wS = Worksheets("Sheet1")
    '▼E3～E5セル以外のセルまたは複数セルが変化した場合は何もしない
    If Intersect(Target, Range("E3:E5")) Is Nothing Or Target.Count > 1 Then Exit Sub
     '▼変化したセルの・・・・
     With Target
        '▼変化したデータをSheet1のA～C列内（.Row-2　なので仮にE3セルが変化した場合は「1」となりSheet1のA列が参照範囲となる）
        'で完全一致のセルを探す。
        Set c = wS.Columns(.Row - 2).Find(what:=.Value, LookIn:=xlValues, lookat:=xlWhole)
            '▼Sheet1に「そのデータ」（完全一致）があれば・・・
            If Not c Is Nothing Then
                '▼Sheet1の「そのデータ」行のA～C列をコピー
                wS.Cells(c.Row, "A").Resize(, 3).Copy
                '▼E3セルに「行列を入れ替えて」貼り付け
                Range("E3").PasteSpecial Paste:=xlPasteAll, Transpose:=True
                '▼変化セルを選択
                .Select
            '▼Sheet1に「そのデータ」がない場合・・・
            Else
                '▼メッセージボックスを表示させ、「はい」=Yes　の場合は
                If MsgBox("該当データがありません" & vbCrLf & "再入力しますか？", vbYesNo) = vbYes Then
                    '▼E3～E5を消去
                    Range("E3").Resize(3).ClearContents
                    '▼変化セルを選択
                    .Select
                '▼そうでない場合（「NO」を選択した場合）は
                Else
                    'マクロを終了
                    Exit Sub
                End If
            End If
    End With
End Sub 'この行まで