Excel (VBA)

Excel VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(Windows 10 Home : Excel 2016)
ExcelのVBAの検索についてのご質問です。
投稿日時: 17/11/30 14:14:50
投稿者: しゅぬ

VBAを利用してマスター管理表を作成・更新をしようとしています。
 
 
Masterシート、Additionalシートの2シートを準備しまして、
 
Master:名前【入力済み】・年齢【入力済み】・性別・利き腕【入力済み】・出身・家族構成【入力済み】・血液型
Additional:ID・名前・性別・出身・血液型
 
の情報が入っている状態とします。
 
 
1.検索条件をAdditional内の名前にし、
 検索範囲をMasterに設定。
 
2.該当するものがあった場合、
 Additional内の各項目(性別、出身、血液型)をコピー、
 Master内の該当したセルの(0,3)(0,5)(0,Coolにペースト
 
3.該当するものがなかった場合、
 そのままスルーする。
 
4.上記の2番3番をAdditionalシート内で全行実施
 
上記のようなロジックになるかと考えています。
現在マクロを勉強しながら作成している為、助けていただければと思います。
 
宜しくお願いいたします。

回答
投稿日時: 17/11/30 14:55:07
投稿者: もこな2

一応、テンプレ的なところから。
「Q&A 掲示板ご利用上のお願い」の「禁止事項」に以下のようにあります。
コード制作依頼
「●●●を実行するようなマクロを作りたいのですが」「●●●をする方法を教えてください」といった、コード制作依頼ともとれるような質問はおやめください。
 
ですので、やりたいことだけ説明して丸投げするようなご質問ですと、なかなか回答がつきづらいと思われます。
すでに、ロジックが固まっているようですので、実際に作ってみることをオススメします。
 
さて、小言みたいないことだけ回答してもしょうが無いので、ヒントというか自分なら、こうするなぁというアイデアを回答投稿します。
作戦1:For〜Nextで最終行になるまでループ処理の入れ子
作戦2:Do 〜 Loop でループ処理の入れ子
作戦3:Dictionaryオブジェクトを使って「Master」シートの「名前」をキーに、同シートのほかの情報をアイテムにした連想配列を作成後にAdditionalシートの処理を実行。
 
たぶん、一番早いのは作戦3だとおもいますけど、ちゃんと無駄ループを回避するようにしてあげれば、作戦1でも作戦2でも、困るようなことはなさそうな気がします。

回答
投稿日時: 17/11/30 15:06:50
投稿者: もこな2

よく考えたら入れ子じゃなくてもいいですね
作戦4:Masterシートの検索キー(名前)を取得して、Find関数で「Additional」を検索。条件判定して必要があれば処理。 をループ

回答
投稿日時: 17/11/30 15:26:09
投稿者: sk

引用:
Master:名前【入力済み】・年齢【入力済み】・性別・利き腕【入力済み】・出身・家族構成【入力済み】・血液型
Additional:ID・名前・性別・出身・血液型
 
の情報が入っている状態とします。

引用:
1.検索条件をAdditional内の名前にし、
 検索範囲をMasterに設定。
 
2.該当するものがあった場合、
 Additional内の各項目(性別、出身、血液型)をコピー、
 Master内の該当したセルの(0,3)(0,5)(0,8)にペースト
 
3.該当するものがなかった場合、
 そのままスルーする。
 
4.上記の2番3番をAdditionalシート内で全行実施

(標準モジュール)
---------------------------------------------------------------------
Sub subUpdateMaster()
 
    Dim wb As Excel.Workbook
    Dim ws_m As Excel.Worksheet
    Dim ws_a As Excel.Worksheet
    Dim rng_m As Excel.Range
    Dim rng_a As Excel.Range
    Dim rng_find As Excel.Range
     
    Dim lngRow As Long
    Dim lngFirstRow As Long
    Dim lngLastRow As Long
     
    Set wb = ThisWorkbook
     
    Set ws_a = wb.Worksheets("Additional")
    Set rng_a = ws_a.UsedRange
     
    lngFirstRow = 2 '1行目が列見出し行、2行目以降がデータ行である場合
    lngLastRow = ws_a.UsedRange.Rows.Count
     
    If lngFirstRow > lngLastRow Then
        MsgBox ws_a.Name & " にはデータ行がありません。", _
               vbInformation, _
               "更新不要"
        Set rng_a = Nothing
        Set ws_a = Nothing
        Set wb = Nothing
        Exit Sub
    End If
         
    Set ws_m = wb.Worksheets("Master")
    Set rng_m = ws_m.Columns(1)
         
    For lngRow = lngFirstRow To lngLastRow
        Set rng_find = rng_m.Find(What:=rng_a.Cells(lngRow, 2).Value, _
                                  LookIn:=xlValues, _
                                  LookAt:=xlWhole)
        If Not rng_find Is Nothing Then
            '性別
            rng_find.Offset(0, 2).Value = rng_a.Cells(lngRow, 3).Value
            '出身
            rng_find.Offset(0, 4).Value = rng_a.Cells(lngRow, 4).Value
            '血液型
            rng_find.Offset(0, 6).Value = rng_a.Cells(lngRow, 5).Value
        End If
        Set rng_find = Nothing
    Next
     
    Set rng_a = Nothing
    Set rng_m = Nothing
    Set ws_a = Nothing
    Set ws_m = Nothing
    Set wb = Nothing
     
End Sub
---------------------------------------------------------------------

投稿日時: 17/11/30 15:27:53
投稿者: しゅぬ

もこな2様
 
Q&Aの確認せずの投稿、大変失礼しました。
また、アドバイスありがとうございます。
 
現在思案中の物を載せさせていただきます。
 

Sub test()

Dim rng As Range
Dim WS As Worksheet, i

Set WS = Worksheets("Master")
With Worksheets("Additional")


For Each rng In .Range("B2", .Cells(Rows.Count, 2).End(xlUp))
i = Application.Match(rng.Value, WS.Columns(1), 0)

If Not IsError(i) Then
[u]rng.Offset(, 1).Resize(, 3).Copy WS.Cells(i, 3)[/u]

End If

Next rng

End With
End Sub

 
上記のコードですと、まとめての貼り付けになってしまう為
代替案を模索中です。

回答
投稿日時: 17/11/30 15:34:20
投稿者: sk

補足:

引用:
1.検索条件をAdditional内の名前にし、
 検索範囲をMasterに設定。

この部分に関しては、
 
・[Master]上で[名前]( A 列)の値が重複することはない。
 
・[Additional]上で[名前]( B 列)の値が重複することはない。
 
という 2 つの前提を満たしているか否かによって、
検索の範囲や手順を適宜修正する必要があるでしょう。

回答
投稿日時: 17/11/30 15:37:24
投稿者: bi

あちらのサイトでコードが提示されて解決したと思ったらこちらも続いていたので一応書きます。
OffsetではなくVLOOKUPを使う方法です。
 

Sub test()

    Application.ScreenUpdating = False
    
    For i = 2 To Sheets("Master").Cells(Rows.Count, 1).End(xlUp).Row
        Sheets("Master").Cells(i, "C").Value = Evaluate("IFERROR(VLOOKUP(A" & i & ",Additional!B:E,2,FALSE),"""")")
        Sheets("Master").Cells(i, "E").Value = Evaluate("IFERROR(VLOOKUP(A" & i & ",Additional!B:E,3,FALSE),"""")")
        Sheets("Master").Cells(i, "G").Value = Evaluate("IFERROR(VLOOKUP(A" & i & ",Additional!B:E,4,FALSE),"""")")
    Next

    Application.ScreenUpdating = True

End Sub

回答
投稿日時: 17/11/30 16:19:49
投稿者: baoo

しゅぬさん思案に沿った形でなら下記のようになるかと思います。

Sub test()

    Dim rng As Range
    Dim WS As Worksheet
    Dim i As Long
    
    Const COL_MASTER_SEX = 3
    Const COL_MASTER_NATION = 5
    Const COL_MASTER_BLOOD = 8
    Const COL_ADD_SEX = 3
    Const COL_ADD_NATION = 4
    Const COL_ADD_BLOOD = 5
    
    On Error Resume Next
    Set WS = Worksheets("Master")
    With Worksheets("Additional")
        For Each rng In .Range("B2", .Cells(Rows.Count, 2).End(xlUp))
            'i = Application.Match(rng.Value, WS.Columns(1), 0) 'MATCH関数を使うなら下が正しい
            i = WorksheetFunction.Match(rng.Value, WS.Columns(1), 0)
            'If Not Error(i) Then 'Error(i)はiに指定のエラーメッセージを表示するだけで、エラー発生とは無関係
            If Err.Number = 0 Then
                'rng.Offset(, 1).Resize(, 3).Copy WS.Cells(i, 3)
                'コピーを使わなければ良い
                WS.Cells(i, COL_MASTER_SEX).Value = .Cells(rng.Row, COL_ADD_SEX).Value
                WS.Cells(i, COL_MASTER_NATION).Value = .Cells(rng.Row, COL_ADD_NATION).Value
                WS.Cells(i, COL_MASTER_BLOOD).Value = .Cells(rng.Row, COL_ADD_BLOOD).Value
            Else
                Err.Clear
            End If
        Next rng
    End With
    On Error GoTo 0

End Sub
ですが、私が組むとしたらskさんと同じようにFindを使うでしょうね。

回答
投稿日時: 17/11/30 16:25:38
投稿者: mattuwan44

しゅぬ さんの引用:
もこな2様
 
Q&Aの確認せずの投稿、大変失礼しました。
また、アドバイスありがとうございます。
 
現在思案中の物を載せさせていただきます。
 
Sub test()

Dim rng As Range
Dim WS As Worksheet, i

Set WS = Worksheets("Master")
With Worksheets("Additional")


For Each rng In .Range("B2", .Cells(Rows.Count, 2).End(xlUp))
i = Application.Match(rng.Value, WS.Columns(1), 0)

If Not IsError(i) Then
[u]rng.Offset(, 1).Resize(, 3).Copy WS.Cells(i, 3)[/u]

End If

Next rng

End With
End Sub

 
上記のコードですと、まとめての貼り付けになってしまう為
代替案を模索中です。

 
Sub test2()
    Dim rngBase As Range
    Dim rngAdd As Range
    Dim r As Range
    Dim ix As Long
 
    Set rngBase = Worksheets("Master").Range("A1").CurrentRegion
    With Worksheets("Additional").Range("A1").CurrentRegion
        Set rngAdd = Intersect(.Cells, .Offset(1))
    End With
 
    For Each r In rngAdd.Rows
        ix = 0
        On Error Resume Next
        ix = WorksheetFunction.Match(r.Cells(1).Value, rngBase.Columns(1), 0)
        On Error GoTo 0
 
        If ix > 0 Then
            With rngBase.Rows(ix).Cells
                .Item(3).Value = r.Cells(2).Value
                .Item(5).Value = r.Cells(3).Value
                .Item(7).Value = r.Cells(4).Value
            End With
        End If
    Next
End Sub
 
最終的にはセル同士で値の転記をするのだから、
セル範囲を変数に入れておく方がスッキリしそう。
 
あとは、セルの位置をどのように表現するか、
語彙を増やすとよいでしょう^^

回答
投稿日時: 17/11/30 18:17:37
投稿者: もこな2

御思案のワークシート関数のMatch関数を使う場合については、baooさんが既に回答されておられますのでで、私からは作戦4のFindメソッドを使った場合の一例を投稿します
(先ほど、Find関数と誤記してました。すみません。)

Sub 作戦4()
Dim rng As Range, 検索結果 As Range ''--------@
Dim WS As Worksheet, i As Long '---------A
Set WS = ThisWorkbook.Worksheets("Master")

'検索&反映’---------B
With Worksheets("Additional")
    For Each rng In .Range("B2", .Cells(Rows.Count, 2).End(xlUp))
        Set 検索結果 = WS.Columns(1).Find(What:=rng.Value)
        If Not 検索結果 Is Nothing Then
            i = 検索結果.Row
            .Range(.Cells(rng.Row, 2), .Cells(rng.Row, 5)).Value = _
                Array(WS.Range("A" & i), WS.Range("C" & i), WS.Range("E" & i), WS.Range("G" & i))
        End If
    Next rng
End With

'終了処理
    Set rng = Nothing
    Set WS = Nothing
    Set 検索結果 = Nothing

End Sub

 
<解説>
@Findメソッドの結果を受け取るオブジェクトを追加
A元のままだと 「i」がVariant型になるので修正
B「Master」シートに「mg.Value」があるか検索して、あれば「Additional」シートへの反映を実行
 
 
mattuwan44さんが仰るとおり、セル範囲を配列変数に入れた方が見やすいとはおもいますが、強引にやるとなるとこんな感じかとおもいます。

回答
投稿日時: 17/11/30 18:23:54
投稿者: 細雪

しゅぬ さんの引用:

2.該当するものがあった場合、
 Additional内の各項目(性別、出身、血液型)をコピー、
 Master内の該当したセルの(0,3)(0,5)(0,Coolにペースト
 
If Not IsError(i) Then
[u]rng.Offset(, 1).Resize(, 3).Copy WS.Cells(i, 3)[/u]

End If

 
上記のコードですと、まとめての貼り付けになってしまう為
代替案を模索中です。

 
 
スッキリ書こうとするあまり、
エクセルで出来ること、出来ないことの区別が抜けていませんか?
例えば「A1:E1セルをコピーして、A2・C2・E1セルだけに貼り付け」という機能、
エクセルにありましたっけ?
 
そんなわけで、素直に3回コピペしてやれば良いと思いますよ。
    If Not IsError(i) Then
        rng.Copy WS.Cells(i, 3)
        rng.Offset(, 2).Copy WS.Cells(i, 5)
        rng.Offset(, 4).Copy WS.Cells(i, 7)
   End If
 
ワークシート関数MATCHに頼るのが良いのか、
VBAのFind関数(エクセルの検索)を使うのが良いのか、
好みが分かれるかもしれませんが、私個人はFind関数で行番号を取得が好きです。
マクロの記録で録れますので、ご興味がおありでしたらお試しください。
 
※最大限活かして。(私の趣味を前面に出して)
Sub test()
Dim WS As Worksheet
Dim ARow As Long, MRow As Long
 
    Set WS = Worksheets("Master")
    With Worksheets("Additional")
        For ARow = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
            On Error Resume Next ' エラー無視
            MRow = WS.Columns("A").Find(What:=.Cells(ARow, 2).Value).Row
                    ' ↑見つからなかったらエラー「91」が返る
            If Err.Number <> 91 Then ' 見つからない時はスルー
                WS.Cells(MRow, 3) = .Cells(ARow, 2)
                WS.Cells(MRow, 5) = .Cells(ARow, 4)
                WS.Cells(MRow, 7) = .Cells(ARow, 6)
            End If
            On Error GoTo 0 ' エラー無視解除(エラーコード=0に戻す)
        Next ARow
    End With
End Sub
 
テストしていないので、どこか間違えているかも。
 
 
 
どちらにしても、Masterシート内に重複が無いことを祈るばかりですね。
可能性は高くはないですが「同姓同名」もあり得ますのでね。
・・・重複が無いなら、VLOOKUP関数で良いかも・・・
まぁ、勉強中のようですので、いろんな書き方があるという事でお納めください。

回答
投稿日時: 17/12/01 15:14:04
投稿者: もこな2

(皆さんのコメント等を読んで)
たしかに、同姓同名の人がいるかもしれませんね。
当該を踏まえて、投稿したコードを修正。(ほかにもミスしてたのでこっそり修正)
 

Sub 作戦4改()
Dim rng As Range, 検索結果 As Range
Dim WS As Worksheet, i As Long
Dim 最初のセル As Range, TmpRNG As Range '同姓同名対策で使用
Set WS = ThisWorkbook.Worksheets("Master")

'検索&反映
With Worksheets("Additional")
    For Each rng In .Range("B2", .Cells(Rows.Count, 2).End(xlUp))

        'とりあえず「Findメソッド」で「rng.Value」に合致するものがあるかチェックして
        'あれば「検索結果」に該当セルを格納
        Set 検索結果 = WS.Columns(1).Find(What:=rng.Value)

        'さらに、該当するものがたくさんあるかもしれないので「FindNextメソッド」を
        '最初のセルになるまでループさせて、見つかったら「検索結果」に追加(同姓同名対策)
        If Not 検索結果 Is Nothing Then
            Set 最初のセル = 検索結果
            Set TmpRNG = 検索結果
            Do
                Set TmpRNG = WS.Columns(1).FindNext(TmpRNG)
                If 最初のセル.Address = TmpRNG.Address Then Exit Do
                Set 検索結果 = Union(検索結果, TmpRNG)
            Loop
        End If

        'Select Caseで処理判定[反映、重複、スルー]
        Select Case True
            Case 検索結果 Is Nothing '1件もヒットしない場合(=「検索結果」がNothing)スルー

            Case 検索結果.Count = 1 '1件のみヒットであれば「Additional」へ反映
                i = 検索結果.Row
                .Range(.Cells(rng.Row, 3), .Cells(rng.Row, 5)).Value = _
                    Array(WS.Range("C" & i), WS.Range("E" & i), WS.Range("G" & i))

            Case 検索結果.Count > 1 '複数ヒットしたら「Additional」へ重複していると書き込んで警告
                .Cells(rng.Row, "C").Value = _
                    "重複エラー:「" & WS.Name & "」の" & Replace(検索結果.Address, "$", "")

            Case Else 'エラーが出たときの分析用(ブレークポイントのかわり)
                Stop
        End Select
    Next rng
End With

'終了処理(好みでオブジェクト解放)
    Set rng = Nothing: Set WS = Nothing
    Set 最初のセル = Nothing: Set TmpRNG = Nothing

End Sub

トピックに返信