[[20150326225242]]　『完全一致検索(複数列)』（いっちゃん）　ページの最後に飛ぶ

『完全一致検索(複数列)』（いっちゃん）

dataを格納したsheet1とdataを抜出表示させるsheet2があり、
sheet1のセルには
Ａ列１行目に5592、２行目に5593、３行目に5583、４行目に5592
Ｂ列１行目に田中、２行目に田中、３行目に鈴木、４行目に鈴木
が入っています。
ここで、sheet2のＸ列１行目に田中と入力すると、
sheet2のＡ列１行目に5592、Ｂ列１行目に田中と
sheet2のＡ列２行目に5593、Ｂ列２行目に田中と表示され、

今度は、sheet2のＸ列１行目に5592と入力すると、
sheet2のＡ列１行目に5592、Ｂ列１行目に田中と
sheet2のＡ列２行目に5592、Ｂ列２行目に鈴木と表示され、

最後に、sheet2のＸ列１行目に5583と入力すると、
sheet2のＡ列１行目に5583、Ｂ列１行目に鈴木と表示される

このようなマクロを組みたいのですが、可能でしょうか。

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

一応できましたが変数の格納の仕方が少しわからないのであとは他の人に任せます。

Sub aaa()
Dim a As Integer
Dim b As Integer
Dim c(50) As Integer
Dim d As Integer
Dim e As Integer
a = 1
b = 1
Do Until b = 3

    Do Until a = 6
    If Sheets(2).Cells(1, 4).Value = Cells(a, b).Value Then
    Cells(1, 5).Value = a
    c(1) = a
    d = 2
    a = a + 1
        Do Until a = 6
        If Sheets(2).Cells(1, 4).Value = Cells(a, b).Value Then
        c(d) = a
        d = d + 1
        End If
        a = a + 1
        Loop
    e = d
    d = 1
        Do Until d = e
        Sheets(2).Cells(d, 1).Value = Cells(c(d), 1).Value
        Sheets(2).Cells(d, 2).Value = Cells(c(d), 2).Value
        d = d + 1
        Loop
    Exit Sub
    End If
    a = a + 1
    Loop
a = 1
b = b + 1
Loop
End Sub
（スズメ） 2015/03/27(金) 00:13

 Sheet2 のシートモジュール（シートタブを右クリック、コードの表示を選ぶ）に。

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim inp As Variant
    Dim col As Long
    Dim c As Range
    Dim v As Variant

    If Intersect(Range("X1"), Target) Is Nothing Then Exit Sub      'X1 への入力以外は終了

    Application.EnableEvents = False                                '無駄なイベント発生の抑止

    Range("A1").CurrentRegion.ClearContents                         '転記領域のクリア
    inp = Range("X1").Value
    If IsNumeric(inp) Then                                          '入力が数字か？
        col = 1             'Sheet1 の A列を検索
    Else
        col = 2             'Sheet2 の B列を検索
    End If

    For Each c In Sheets("Sheet1").Range("A1").CurrentRegion.Columns(col).Cells   'Sheet1の検索列からセルを抜きだし

        If c.Value = inp Then                                               'X1に入力されたものとの比較
            If IsArray(v) Then
                ReDim Preserve v(1 To UBound(v) + 1)                        '２回目以降は配列の要素を１つ増やす
            Else
                ReDim v(1 To 1)                                             '最初なら配列初期化
            End If
            v(UBound(v)) = c.EntireRow.Range("A1:B1").Value                 '配列の最後の要素に格納
        End If
    Next

    '該当のものがあれば、それを一括転記
    If IsArray(v) Then Range("A1").Resize(UBound(v), 2).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(v))

    Application.EnableEvents = True                                         'イベント発生再開

 End Sub

（β） 2015/03/27(金) 08:04

 Sheet1 の データ件数が多く、検索ヒットが少ない場合は以下のほうが少し効率的。
 (データ件数が少なかったり、検索ヒットが、結構多ければ、先にアップしたコードのほうが効率的。）

 同じくシートモジュールに。

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range
    Dim v As Variant
    Dim f As Range
    Dim r As Range

    If Intersect(Range("X1"), Target) Is Nothing Then Exit Sub      'X1 への入力以外は終了

    Application.EnableEvents = False                                '無駄なイベント発生の抑止

    Range("A1").CurrentRegion.ClearContents                         '転記領域のクリア

    Set r = Sheets("Sheet1").Range("A1").CurrentRegion              'Sheet1 検索領域

    Set c = r.Find(what:=Range("X1").Value, LookAt:=xlWhole)        '入力された値で検索

    If Not c Is Nothing Then                                        '検索でマッチすれば

        Set f = c                                                   '最初に見つかったセルを記憶

        Do
            If IsArray(v) Then
                ReDim Preserve v(1 To UBound(v) + 1)                        '２回目以降は配列の要素を１つ増やす
            Else
                ReDim v(1 To 1)                                             '最初なら配列初期化
            End If
            v(UBound(v)) = c.EntireRow.Range("A1:B1").Value                 '配列の最後の要素に格納

            Set c = r.FindNext()                                    '検索　「次へ」

        Loop While f.Address <> c.Address                           '最初に見つかったものに戻るまで繰り返し

        '一括転記
        Range("A1").Resize(UBound(v), 2).Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(v))

    End If

    Application.EnableEvents = True                                         'イベント発生再開

 End Sub

（β） 2015/03/27(金) 08:24

変数の格納の仕方がわかったので、2015/03/27(金) 00:13のマクロを修正します。

Sub aaa()

 Dim a As Integer
 Dim b As Integer
 Dim c() As Integer
 Dim d As Integer
 Dim e As Integer
 a = 1
 b = 1
 Do Until b = 3
    Do Until a = 6
    If Sheets(2).Cells(1, 4).Value = Cells(a, b).Value Then
    Cells(1, 5).Value = a
    ReDim c(1)
    c(1) = a
    d = 2
    a = a + 1
        Do Until a = 6
        If Sheets(2).Cells(1, 4).Value = Cells(a, b).Value Then
        ReDim Preserve c(d)
        c(d) = a
        d = d + 1
        End If
        a = a + 1
        Loop
    e = d
    d = 1
        Do Until d = e
        Sheets(2).Cells(d, 1).Value = Cells(c(d), 1).Value
        Sheets(2).Cells(d, 2).Value = Cells(c(d), 2).Value
        d = d + 1
        Loop
    Exit Sub
    End If
    a = a + 1
    Loop
a = 1
b = b + 1
Loop
End Sub

あとはいっちゃんさんの環境に合わせて変更してください。

（スズメ） 2015/03/27(金) 13:36

 余計なお世話かもしれませんが、スズメさんのインデントの独自スタイルは
 矯正してはどうでしょうか。

 見づらいだけでなく、バグの元かと思います。

 例えば、If が入れ子になったときなど、スズメさん風だとインデントが付かないので
 ブロックの範囲がわかりません。

 If A = 1 Then
 If B = 2 Then
 MsgBox "Apple"
 Else
 MsgBox "Blue"
 End If
 Else 
 If C = 3 Then
 MsgBox "Cat"
 Else
 MsgBox "Dog"
 If D = 4 Then
 MsgBox "Egg"
 Else
 MsgBox "Fish"
 End If
 End If
 End If

 これでは、どの条件のときにどのメッセージが出るのか、
 どの If と どの End If が対応しているかわからないかと思います。

 If A = 1 Then
     If B = 2 Then
         MsgBox "Apple"
     Else
         MsgBox "Blue"
     End If
 Else 
     If C = 3 Then
         MsgBox "Cat"
     Else
         MsgBox "Dog"
         If D = 4 Then
             MsgBox "Egg"
         Else
             MsgBox "Fish"
         End If
     End If
 End If

 と書いた方がわかりやすくないですか？
（Mook） 2015/03/27(金) 14:09

if関数もインテンドが必要とは知りませんでした。すいません。
（スズメ） 2015/03/27(金) 14:49

 >if関数もインテンドが必要とは知りませんでした。すいません。

 あやまる必要はまったっくないですよ。
 ただ、必要かどうかより、(スズメ)さんにとって見やすいかどうか、わかりやすいかどうかということなんです。

 当初と比べて、大きなブロックごとではインデントをそろえておられるので、ずいぶん（いくぶん？）見やすくなっていると思いますが
 それでも

        Do Until a = 6
        If Sheets(2).Cells(1, 4).Value = Cells(a, b).Value Then
        ReDim Preserve c(d)
        c(d) = a
        d = d + 1
        End If
        a = a + 1
        Loop

 なんかは

        Do Until a = 6
           If Sheets(2).Cells(1, 4).Value = Cells(a, b).Value Then
              ReDim Preserve c(d)
              c(d) = a
              d = d + 1
           End If
           a = a + 1
        Loop

 このほうが(スズメ)さんご自身にとっても見やすくないですか？

 ところで、この Do Until a = 6 の 6 って何ですか？
 それと、「Sheet2のX列1行目」つまり X1 に入力するんですけど、X1のチェックはどこでしておられますか？

（β） 2015/03/27(金) 14:52

 細かいことだが。

 IF関数はワークシートで使える関数。
 VBAで使っているのはIF構文（ステートメント）。
 IF関数に対応するのはIif関数になる。

 また、インデントを行うのはIF構文のブロック形式になる。
（ねむねむ） 2015/03/27(金) 14:59

if文については、ifの重複が少ない時は、インテンドがなくても十分理解できるので、要らないと思いますが(インテンドを入れるのは面倒なので)、10個くらい重複する時は要ると思います。

Xは本当にX列を意味するのでしょうか？Xはよく数学の方程式で使われるので、オールマイティの意味で使われている可能性は否定できません。つまり、どこの列でも使えるということです。

それに、なぜX列じゃないといけないのでしょうか？AやB列に書き込むのに、X列は遠すぎると思うのですが。

あと、6というのはあくまで実験でやったので、そこは質問者様のデータ数に合わせるということです。
（スズメ） 2015/03/27(金) 15:32

 >インテンドを入れるのは面倒なので

 VBE画面でタブキーを押すだけのことですが？

 >あと、6というのはあくまで実験でやったので、そこは質問者様のデータ数に合わせるということです。

 データが増減するたびにコードを書き直すということですか？

 ★もともとのテーマとは、だんだんかけ離れて行ってますね。（私も反省）
 　そろそろ、（ここでは）打ち止めにしましょう。

 （いっちゃん） さん、スレ汚してごめんなさいね。

（β） 2015/03/27(金) 15:37

コメント返信：

[ 一覧(最新更新順) ]

[[20150326225242]] 『完全一致検索(複数列)』（いっちゃん） ページの最後に飛ぶ

[[20150326225242]]　『完全一致検索(複数列)』（いっちゃん）　ページの最後に飛ぶ