受講生 さん:

こんにちは。

For Next構文を複数組み合わせることでマッチングをできるようになった。
ただし、データの件数が多いため、マクロ実行時間短縮のため、より高速にマッチングできる方法を求めている。
そこで、配列を使うとマッチングを高速化できるのではなのではないかと考えた。
ついては、この見立ては適切かどうか教えてほしい。
また、適切だということならば、より具体的な方針について相談したい。

ということかと思います。

さて、では、マッチングのパフォーマンスが配列を使うと改善するか？というと。
するにはしますが、そんなに劇的には変わらないかと思います。理由は、この回答の最後に示します。


マッチングのパフォーマンスを上げるための進化のプロセスは、以下のとおりです。

[1] For Next構文を複数組み合わせることでマッチングをできるようになる
[2] For Each構文を複数組み合わせることでマッチングをできるようになる
[3] Findメソッドを使うことでマッチングをできるようになる
[4] SQLのSELECT文を使うことでマッチングできるようになる

以下、受講生さんは[1]はもうできるという前提で話を進めます。
また、該当するNo.がない場合はデータの下部に転記するというところまでできるという前提です。

話を簡単にするため、同一シート内にある2つの表でマッチングするものとしましょう。

左の表はA-D列、2行目から201行目まで。
右の表はF-I列、2行目から251行目まで。
A列とF列で値が一致したら、G列の値をD列に転記する。
マッチするレコードは0件か1件。

'【参考】以下は、デモデータ作成マクロ

Sub sample0()
    Randomize
    Dim hida As Long
    For hida = 2 To 201
        Range("A" & hida).Value = hida - 1
        Range("B" & hida).Value = "hida1 " & hida - 1
        Range("C" & hida).Value = "hida2 " & hida - 1
    Next

    For hida = 2 To 251
        Range("F" & hida).Value = hida - 1
        Range("G" & hida).Value = "migi1 " & hida - 1
        Range("H" & hida).Value = Rnd()
    Next
    Range("F1").CurrentRegion.Sort Key1:=Range("H1"), Order1:=xlAscending, Header:=xlYes
End Sub

すると、[1]では、以下の要領ですね。

Sub sample1()
    Dim hida As Long
    Dim migi As Long
    For hida = 2 To 201
        For migi = 2 To 251
            If Range("A" & hida).Value = Range("F" & migi).Value Then
                Range("D" & hida).Value = Range("G" & migi).Value
                Exit For
            End If
        Next
    Next
End Sub

[2] For Each構文を使ったほうが高速化はします。
For Next構文だと、 Range("A" & hida) 等と指定する都度、該当するセルを探してメモリに格納する。
一方、For Each構文では、処理対象のセルのすべてへの参照をいったんメモリに格納し、それから処理するから。探索対象を実際にセルを見に行って割り出すか、Forループ開始時にあらかじめメモリに入れておいたリストから見つけるか？の違い。プログラム実行領域が確保しているメモリへのアクセスのほうが当然に高速です。

Sub sample2_1()
    Dim rHall As Range
    Dim rMall As Range
    Dim rH As Range
    Dim rM As Range
    
    Set rHall = Range("A2:A201")
    Set rMall = Range("F2:F251")
    
    For Each rH In rHall
        For Each rM In rMall
            If rH.Value = rM.Value Then
                rH.Offset(, 3).Value = rM.Offset(, 1)
                Exit For
            End If
        Next
    Next
End Sub

以下でも結果は変わりません。
変数をむやみに宣言するのを嫌うならばこういう書き方もあり。

Sub sample2_2()
    Dim rH As Range
    Dim rM As Range
    
    For Each rH In Range("A2:A201")
        For Each rM In Range("F2:F251")
            If rH.Value = rM.Value Then
                rH.Offset(, 3).Value = rM.Offset(, 1)
                Exit For
            End If
        Next
    Next
End Sub

[3] さて、次に、.Findメソッドです。
発展編1で学んだ要領で自動記録をしつつエクセル画面から検索をすると、 .Find メソッドのコードのサンプルを得られます。

以下は、B列セルのB2:B201を選択した状態で "hida1 171" をキーワードに完全一致で検索した場合に得られるコードの例。
(エクセルのバージョンや環境によって得られるコードは多少異なります)

Sub Macro1()
'
' Macro1 Macro
'

'
    Range("B2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Find(What:="hida1 171", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, MatchByte:=False, SearchFormat:=False).Activate
End Sub

整形して不要部分を削除してみます。

以下でも動きます。

Sub FindSample()
    Range("B2:B201").Find(What:="hida1 171", LookIn:=xlFormulas, LookAt:=xlWhole).Activate
End Sub

(本当は、 LookIn:=xlFormulas もこのケースでは不要です。MSDNの公式ヘルプ等でもご自身で調べてみてください
https://docs.microsoft.com/ja-jp/office/vba/api/excel.range.find )

検索機能を使うことのメリットは、ループ内で値を拾って調べる処理を書かないでも、エクセルが一発で該当する値を見つけてくれることです。

ということで、さきほどの[2]で提案したマクロは、以下のように書き換えられます。
まずは、該当するレコードが、必ず、1件だけ存在する場合。

Sub sample3_1()
    Dim rHall As Range
    Dim rMall As Range
    Dim rH As Range
    
    Set rHall = Range("A2:A201")
    Set rMall = Range("F2:F251")
    
    For Each rH In rHall
        rH.Offset(, 3).Value = rMall.Find(what:=rH.Value, lookat:=xlWhole).Offset(, 1).Value
    Next
End Sub

面倒なのは、以下のそれぞれの場合です。
[3-A] 該当するレコードがみつからない場合
[3-B] 該当するレコードが複数ある場合

[3-A] でのNG例として、以下のコードを書いてみました。
左の表と右の表を比較して、マッチングしたら左の表の値を右の表に転記します。
しかし、右の表でIDが200を超えるものについて処理しようとしたところでエラーになります。
.Findメソッドの戻り値が Nothing (つまり、当該セルは存在しない)となるからです。

Sub sample3_2()
    Dim rHall As Range
    Dim rMall As Range
    Dim rM As Range
    
    Set rHall = Range("A2:A201")
    Set rMall = Range("F2:F251")
    
    For Each rM In rMall
        rM.Offset(, 3).Value = rHall.Find(what:=rM.Value, lookat:=xlWhole).Offset(, 1).Value
    Next
End Sub

このエラーの回避策は、.Findメソッドの戻り値が Nothing かどうかによって処理を分岐することです。
以下の要領。

Sub sample3_3()
    Dim rHall As Range
    Dim rMall As Range
    Dim rH As Range
    Dim rM As Range
    
    Set rHall = Range("A2:A201")
    Set rMall = Range("F2:F251")
    
    For Each rM In rMall
        Set rH = rHall.Find(what:=rM.Value, lookat:=xlWhole)
        If Not rH Is Nothing Then
            rM.Offset(, 3).Value = rH.Offset(, 1).Value
        Else
            rM.Offset(, 3).Value = "見つかりません"
        End If
    Next
End Sub

[3-B]の検索結果が複数存在する場合の処理については、前記MSDNサイトで「検索を繰り返すには、 FindNext および FindPrevious メソッドを使用できます。」という項目あたりを調べてみてください。
ひとつのご質問への回答としてはそこまで書くとボリュームが大きくなりすぎるのでというのと、ご期待だった配列を使った解法からかなりそれた方法の提案ということもあるので、僕からの解説はこのくらいにします。

SQLを使う方法の件についても、上記と同様の理由で省略します。外部連携講座の範囲になりますし。
まずは上記[3]に習熟してもらえれば、と思います。


最後に、この課題で配列を使うと高速化するのか？という件について書きます。
配列に値なりセル範囲への参照なりを格納しても「各要素を順番に取り出して比較していく」というやり方だと[1], [2]と変わらないので、[3]の .Find メソッドには及びません。


以上です。
参考になれば、と思います。

2019/11/24 23:00

小川先生:

こんにちは。
サンプルコードまでたくさん記載いただきありがとうございます。

情報が少なくてすみませんでした。
先生の予想ですべて合っております。
・重複コードはなしです。
・発展1のForNext文で（1）と同じように作成済です。

まず、いただいたコードのとおり表を作り、(2)(3)を実行し動きがわかった上で、自分の5000行の2つのsheetにコードを置き換えて実行してみました。
（1）ForNext文→自分で以前に作成済（実行時間3分15秒）
　　→1セルずつなので結構かかります

（2）ForEach文→先生のコードを参考に作成（実行時間44秒）
　　→こんなに短くなりました！！

（3）ForEach文でFind関数で前月No→当月Noを検索し転記
　　→実はここで引っかかりました。。1つのsheetでテストしたときは大丈夫でしたが、2つのsheetにわけて下記のように実行すると存在するNoもすべて（見つかりません）と前月sheetに書きこまれ、当月sheetには一つも転記されませんでした。どこが悪いかわかりますでしょうか？2つのsheetですが（2）のテストでは下記のような感じでもうまくいったので、ちょっと自分ではわかりません。。なお「rM」の上にカーソルを合わせるとデータが表示されましたが、「rH」の上ではNothingと表示されました。見て頂けると助かります。よろしくお願いいたします。
--------------------------------------
●　ws1→当月⇔前月対比sheet（No:C列）F列から転記とする
●　ws2→前月sheet（No:C列、Noなし:A列に見つかりません）
●　転記先20行目～の rHとrMのみ左右の場所を入れ替えました

Sub sample3_3()
    Public ws1 As Worksheet
    Public ws2 As Worksheet
    Public tmax As Long
    Public zmax As Long    
 ----------------------------
    Dim rHall As Range
    Dim rMall As Range
    Dim rH As Range
    Dim rM As Range
    
    Set ws1 = Worksheets("当月対比")
    Set ws2 = Worksheets("前月")
    tmax = ws1.Range("F1048576").End(xlUp).Row
    zmax = ws2.Range("F1048576").End(xlUp).Row
    
    Set rHall = ws1.Range("C2","C" & tmax)　
    Set rMall = ws2.Range("C2","C" & zmax)　
     
    For Each rM In rMall
        Set rH = rHall.Find(what:=rM.Value, lookat:=xlWhole)
        If Not rH Is Nothing Then
            rH.Offset(, 3).Value = rM.Offset(, 3).Value
　　　 rH.Offset(, 4).Value = rM.Offset(, 4).Value
　　　　　　・
　　　　　　・
　　　　　　
        Else
            rM.Offset(, -2).Value = "見つかりません"　
        End If
    Next
End Sub

2019/11/26 06:25

>（1）ForNext文→自分で以前に作成済（実行時間3分15秒）
>　　→1セルずつなので結構かかります
>
>（2）ForEach文→先生のコードを参考に作成（実行時間44秒）
>　　→こんなに短くなりました！！
↑
これは、興味深いですね。

さて、いただいたさらなるご質問について。

これは、プログラムのロジックではなく、調査対象のデータの問題ではないかと思います。
というのは、以下の[1], [2]からです。

[1] 別シートにあるデータの比較も可能です
[2] いただいたマクロが動作し得るサンプルデータを作り試してみましたが、[1]と同様に問題なく動作します

以下に示すサンプルコードを検証してください。
そのうえで、手元の本番データで、前後の空白、大文字小文字、全角半角の違いが生じていないか？検証してください。

この検証の際は、いきなりループでマッチングさせるのではなく、（ハナコのやり方を踏襲し）まずは絶対にマッチングするはずの2つのセルで比較を行い .Find がセルを1つ返すのところまで成功させるのに専念されるのが堅実かと思います。
[3]を参考にしてください。

'[1]
Sub sample0_2() 'Sheet1, Sheet2で元データ投入
    Randomize
    
    Dim hida As Long
    
    Worksheets("Sheet1").Activate
    Range("A1").Value = "ID"
    Range("B1").Value = "val1"
    Range("C1").Value = "val2"
    Range("D1").Value = "val3"
    For hida = 2 To 201
        Range("A" & hida).Value = hida - 1
        Range("B" & hida).Value = "hida1 " & hida - 1
        Range("C" & hida).Value = "hida2 " & hida - 1
    Next

    Worksheets("Sheet2").Activate
    Range("F1").Value = "ID"
    Range("G1").Value = "val1"
    Range("H1").Value = "val2"
    Range("I1").Value = "val3"
    For hida = 2 To 251
        Range("F" & hida).Value = hida - 1
        Range("G" & hida).Value = "migi1 " & hida - 1
        Range("H" & hida).Value = Rnd()
    Next
    Range("F1").CurrentRegion.Sort key1:=Range("H1"), order1:=xlAscending, Header:=xlYes
End Sub
Sub sample4_3() '前回提供したsample3_3の、別シートにあるバージョン
    Dim rHall As Range
    Dim rMall As Range
    Dim rH As Range
    Dim rM As Range
    
    Set rHall = Worksheets("Sheet1").Range("A2:A201")
    Set rMall = Worksheets("Sheet2").Range("F2:F251")
    
    For Each rM In rMall
        Set rH = rHall.Find(what:=rM.Value, lookat:=xlWhole)
        If Not rH Is Nothing Then
            Debug.Print "Found"
            rM.Offset(, 3).Value = rH.Offset(, 1).Value
        Else
            Debug.Print "Not Found"
            rM.Offset(, 3).Value = "見つかりません"
        End If
    Next
End Sub
Sub Sheet1Active() 'Sheet1がアクティブな状態で実行し、Sheet2の状態を確認する
    Worksheets("Sheet1").Activate
    sample4_3
End Sub
Sub Sheet2Active() 'Sheet2がアクティブな状態で実行し、Sheet2の状態を確認する
    Worksheets("Sheet2").Activate
    sample4_3
End Sub

'[2] データ投入先シートは存在し、データ投入されていないという前提。
Option Explicit
Public ws1 As Worksheet
Public ws2 As Worksheet
Public tmax As Long
Public zmax As Long
Sub sample3_3()
    Dim rHall As Range
    Dim rMall As Range
    Dim rH As Range
    Dim rM As Range
     
    Set ws1 = Worksheets("当月対比")
    Set ws2 = Worksheets("前月")
    tmax = ws1.Range("F1048576").End(xlUp).Row
    zmax = ws2.Range("F1048576").End(xlUp).Row
     
    Set rHall = ws1.Range("C2", "C" & tmax)
    Set rMall = ws2.Range("C2", "C" & zmax)
      
    For Each rM In rMall
        Set rH = rHall.Find(what:=rM.Value, lookat:=xlWhole)
        If Not rH Is Nothing Then
            rH.Offset(, 3).Value = rM.Offset(, 3).Value
            rH.Offset(, 4).Value = rM.Offset(, 4).Value
        Else
            rM.Offset(, -2).Value = "見つかりません"
        End If
    Next
End Sub
Sub SetTestData()
    Randomize
    Dim c As Long
    Dim rHall As Range
    Dim rMall As Range
    
    Set ws1 = Worksheets("当月対比")
    Set ws2 = Worksheets("前月")
    
    With ws1
        .Range("C1").Value = "ID"
        .Range("D1").Value = "col1"
        .Range("E1").Value = "col2"
        .Range("F1").Value = "col3"
        .Range("G1").Value = "col4"
        For c = 2 To 31
            .Range("C" & c).Value = c
            .Range("D" & c).Value = "hida " & c
            .Range("E" & c).Value = "hida " & c
            .Range("F" & c).Value = Rnd()
        Next
    End With
    
    With ws2
        .Range("A1", "A" & .Range("A1048576").End(xlUp).Row).ClearContents '文字列"見つかりません"がある場合は削除
        .Range("C1").Value = "ID"
        .Range("D1").Value = "col1"
        .Range("E1").Value = "col2"
        .Range("F1").Value = "col3"
        .Range("G1").Value = "col4"
        For c = 2 To 51
            .Range("C" & c).Value = c
            .Range("D" & c).Value = "migi " & c
            .Range("E" & c).Value = "migi " & c
            .Range("F" & c).Value = Rnd()
        Next
        .Range("C1").CurrentRegion.Sort Key1:=.Range("F1"), Order1:=xlAscending, Header:=xlYes
    End With
    
    tmax = ws1.Range("F1048576").End(xlUp).Row
    zmax = ws2.Range("F1048576").End(xlUp).Row
    
    Set rHall = ws1.Range("C2", "C" & tmax)
    Set rMall = ws2.Range("C2", "C" & zmax)
    
    Debug.Print rHall.Count 'データ数検証。30になるはず。
    Debug.Print rMall.Count 'データ数検証。50になるはず。
End Sub

'[3] ハナコ
Sub hanako1()
    Dim rHall As Range
    Dim rH As Range
    Dim rM As Range
    Dim wH As Worksheet
    Dim wM As Worksheet
    Set wH = Worksheets("当月対比")
    Set wM = Worksheets("前月")
    
    Set rHall = wH.Range("C2") 'ID=2
    Set rM = wM.Range("C13") 'ID=2 のレコードは13行目にあるとします
    Set rH = rHall.Find(what:=rM.Value, lookat:=xlWhole)
    If Not rH Is Nothing Then
        rM.Offset(, 4).Value = rH.Offset(, 1).Value
    Else
        rM.Offset(, 4).Value = "失敗"
    End If
End Sub
Sub hanako2()
    Dim rHall As Range
    Dim rH As Range
    Dim rM As Range
    Dim wH As Worksheet
    Dim wM As Worksheet
    Set wH = Worksheets("当月対比")
    Set wM = Worksheets("前月")
    
    Set rHall = wH.Range("C2:C31") '調査範囲を拡大
    Set rM = wM.Range("C17") '2-31までの値を取る任意のセルを指定
    Set rH = rHall.Find(what:=rM.Value, lookat:=xlWhole)
    If Not rH Is Nothing Then
        rM.Offset(, 4).Value = rH.Offset(, 1).Value
    Else
        rM.Offset(, 4).Value = "失敗"
    End If
End Sub
Sub hanako3()
    Dim rMall As Range
    Dim rHall As Range
    Dim rH As Range
    Dim rM As Range
    Dim wH As Worksheet
    Dim wM As Worksheet
    Set wH = Worksheets("当月対比")
    Set wM = Worksheets("前月")
    
    Set rHall = wH.Range("C2:C31")
    Set rMall = wM.Range("C2:C51")
    For Each rM In rMall
        Set rH = rHall.Find(what:=rM.Value, lookat:=xlWhole)
        If Not rH Is Nothing Then
            rM.Offset(, 4).Value = rH.Offset(, 1).Value
        Else
            rM.Offset(, 4).Value = "失敗"
        End If
    Next
End Sub

2019/11/26 15:00

小川先生:

お世話になります。
早速見ていただきありがとうございます。

サンプルコードを検証しました。
[3]でまた　"失敗"　となったところで、先生の「調査対象のデータの問題」の原因がわかりました。

実はもう一つ情報をお伝えしていなかったのですが、調査対象のコード列（C列）にはコードや名称など複数の列を結合する関数を入れております。
（コードのみだど重複データができてしまい正確に転記できなくなるため）
その関数の結合データの結果で当月⇔前月でマッチングさせておりました。[2]までは普通に動いたので気付かず、すみません。。。

　Set rH = rHall.Find(what:=rM.Value, lookat:=xlWhole)
→Set rH = rHall.Find(what:=rM.Value,LookIn:=xlValues, lookat:=xlWhole)

とういうことで、上記のように変更しましたら無事動きました。
ですが、やはり関数だと8分くらいかかりますので、一度関数を値貼付にして実行したところ16秒でできました！全然違うのですね。。

1列増やして一度値で貼りつけ他のセルを修正するか、[2]のForEachでも44秒なのでどちらか検討いたします。とても勉強になりました。
何度もサンプルデータをいただきありがとうございました。

2019/11/27 08:27

受講生 さん:

> 　Set rH = rHall.Find(what:=rM.Value, lookat:=xlWhole)
> →Set rH = rHall.Find(what:=rM.Value,LookIn:=xlValues, lookat:=xlWhole)
>
> とういうことで、上記のように変更しましたら無事動きました。
> ですが、やはり関数だと8分くらいかかりますので、一度関数を値貼付にして実行したところ16秒でできました！全然違うのですね。。

よく、気づかれましたね！

技術的には、「検索対象を、セルに埋め込まれた式ではなく式の計算結果とするには？」ということですね。
そこだけを焦点にしたサンプルコードを作りました。

また、 Application.Calculation プロパティの値を変更すると、開いているエクセルファイルでセルが編集されても、都度全セルの計算式を再計算しなくなります。
もしまだ活用されていないようでしたら、そのことによる高速化も期待できそうです。(発展編1テキスト参照)

以下を参考にしたコードを書いてみて、最終的にどんな結果になったか？またお聞かせください (^^

Sub SetNewData()
    Randomize
    
    '"一枚シート"という名称のworksheetが存在するという前提
    Dim ws As Worksheet
    Set ws = Worksheets("一枚シート")
    
    Dim c As Long
    With ws
        .Cells.Clear
        .Range("A1").Value = "ID"
        .Range("B1").Value = "col1"
        .Range("C1").Value = "col2"
        .Range("D1").Value = "col3"
        .Range("E1").Value = "rnd"
        .Range("F1").Value = "match"
        For c = 2 To 31
            .Range("A" & c).Value = "h-" & c - 1
            .Range("B" & c).Value = "data"
            .Range("C" & c).Value = c - 1
            .Range("D" & c).Formula = "=B" & c & "&C" & c
            .Range("E" & c).Value = Rnd()
        Next
        .Range("A1").CurrentRegion.Sort Key1:=Range("E1"), Order1:=xlAscending, Header:=xlYes
    
        .Range("H1").Value = "ID"
        .Range("I1").Value = "col1"
        .Range("J1").Value = "col2"
        .Range("K1").Value = "col3"
        .Range("L1").Value = "rnd"
        .Range("M1").Value = "match"
        For c = 2 To 21
            .Range("H" & c).Value = "m-" & c - 1
            .Range("I" & c).Value = "data"
            .Range("J" & c).Value = c - 1
            .Range("K" & c).Formula = "=I" & c & "&J" & c
'            .Range("L" & c).Value = Rnd()
        Next
        .Range("L2:L21").Value = .Range("K2:K21").Value '式で算出された値をそのまま値として貼りつけ(貼りつけ先として同じセルを指定するのもあり)
    End With
End Sub
Sub Find_By_Formula_Result()
    Dim rHall As Range, rMall As Range
    Dim rH As Range, rM As Range
    
    Dim ws As Worksheet
    Set ws = Worksheets("一枚シート")
    
    Application.Calculation = xlCalculationManual
    With ws
        Set rHall = .Range("D2:D31") '式が入っている
        Set rMall = .Range("L2:L21") '値が入っている
        For Each rM In rMall
            Set rH = rHall.Find(What:=rM.Value, Lookat:=xlWhole, LookIn:=xlValues)
            If Not rH Is Nothing Then
                rM.Offset(, 1).Value = rH.Row & "行目にありました！"
            Else
                rM.Offset(, 1).Value = "見つかりません"
            End If
        Next
        Columns(12).Delete Shift:=xlToLeft 'マクロでの処理の都合で一時的に追加していた列を削除
    End With
    Application.Calculation = xlCalculationAutomatic
End Sub

2019/11/29 19:45