vba 行と列を指定→検索して値を転記

Question

###前提・実現したいこと
2つシートがあり、それぞれに表があります。
一つは元表、もう一つは転記先の表です。

転記先の表は91行目まであります。

元表のデータを、「社名」と「見出し」で合致するセルに転記をさせ、元表に社名がない行は、空欄にしたいです。
ワークシート関数ですと、INDEX関数とMATCH関数の組み合わせでクロス検索するという方法があると思いますが、それをマクロで表現したいです。

###該当のソースコード

Sub 作成()

    Const KURIKOSIKIN_COL As Long = 4 '「転記先」シート「繰越税抜金額列」
    
    Const KENSAKU_CLM As Long = 2 '「転記先」シートＢ列
    Const KENSAKU_ROW As Long = 4 '「転記先」シート４行目
    
    Dim Sh_Tenki As Worksheet '「転記先」シート
    
    Dim Data_Hanni As Range 'index関数のデータ範囲
    
    Dim Kensaku_Hanni1 As Range  'match関数の検索する範囲①
    Dim Kensaku_Hanni2 As Range  'match関数の検索する範囲②
    
    Set Data_Hanni = Worksheets("元表").Range(Cells(7, 4), Cells(20, 8)) 'index関数のデータ範囲（$D$7:$H$20）
    Set Sh_Tenki = Worksheets("転記先")    
    Set Kensaku_Hanni1 = Worksheets("元表").Range(Cells(7, 3), Cells(20, 3)) '検索する範囲①（$C$7:$C$20）
    Set Kensaku_Hanni2 = Worksheets("元表").Range(Cells(6, 4), Cells(6, 8)) '検索する範囲②（$D$6:$H$6）
        
    Worksheets("転記先").Cells(5, 4).Value = WorksheetFunction.Index(Data_Hanni, _
    WorksheetFunction.Match(Sh_Tenki.Cells(5, KENSAKU_CLM), Kensaku_Hanni1, 0), _
    WorksheetFunction.Match(Sh_Tenki.Cells(KENSAKU_ROW, 4), Kensaku_Hanni2, 0))

End Sub

###試したこと
INDEX関数とMATCH関数を使って、転記先表の「Ｄ1」だけ転記させることはできました。
（その後FOR～を使って転記先表の91行目まで転記させるように書いてみましたが、うまく行かず、どう直せば良いのかも分かりませんでした）

やり方はこだわりません。
良いやり方がありましたら教えてください。
宜しくお願い致します。

###補足情報(言語/FW/ツール等のバージョンなど)
より詳細な情報

Answer 1

INDEX～MATCHの結果をD5セルに出力することはできていますよね。
これを「ループ処理にしてみたがうまくいかなかった」ということですが、肝心のループ処理のコードが開示されていないので、どう間違えてしまったのかがわかりません。

D列の4と、5行目の5を変数化してループさせたのであれば、やりかたとしては間違っていないと思います。

    Dim iRow As Integer
    Dim iCol As Integer
    For iRow = 5 To 91
        For iCol = 4 To 8
            Sh_Tenki.Cells(iRow, iCol).Value = WorksheetFunction.Index(Data_Hanni, _
                                                    WorksheetFunction.Match(Sh_Tenki.Cells(iRow, KENSAKU_CLM), Kensaku_Hanni1, 0), _
                                                    WorksheetFunction.Match(Sh_Tenki.Cells(KENSAKU_ROW, iCol), Kensaku_Hanni2, 0))
        Next
    Next

原因？

うまく動かなかった原因として、思い当るのはMatch関数のエラーです。

ワークシート上でもMatch関数は検索値が見つからない場合に"N/A"エラーを返したりしますが、これはVBA上でも同じです。
検索値が見つからない行を処理した時点でMatch関数がエラーとなり、そこでエラーメッセージが表示されて処理中断となってしまいます。
このためVBAでMATCH関数を利用する場合、On Errorによるエラートラップがほぼ必須となります。

    'エラーが発生しても無視して処理を継続（乱暴ですが。）
    On Error Resume Next
    
    Dim iRow As Integer
    Dim iCol As Integer
    For iRow = 5 To 91
        For iCol = 4 To 8
            Sh_Tenki.Cells(iRow, iCol).Value = WorksheetFunction.Index(Data_Hanni, _
                                                    WorksheetFunction.Match(Sh_Tenki.Cells(iRow, KENSAKU_CLM), Kensaku_Hanni1, 0), _
                                                    WorksheetFunction.Match(Sh_Tenki.Cells(KENSAKU_ROW, iCol), Kensaku_Hanni2, 0))
        Next
    Next

代案

今回の処理では、１セルの値を取得するたびに「MATCHする社名」「MATCHする項目名」をそれぞれ検索しています。
たしかにワークシート上の１セルでクロス検索する場合にはこれが必要ですが、VBAで行うのであればそこにとらわれる必要もありません。

①転記先シートの行をループ処理
～行ループここから～
　②　社名の一致する行を元表シートから検索する
　③-a　見つからなかった場合
　　⇒何もせず次の行の処理(②)へ
　③-b　見つかった場合
　　⇒転記先シートの列をループ処理
　　～列ループここから～
　　④　項目名の一致する列を元表シートから検索する
　　⑤-a　見つからなかった場合
　　　⇒何もせず次の列の処理(④)へ
　　⑤-b　見つかった場合
　　　⇒元表の行番号・列番号のセルから値を取得し、転記先シートの対象行・対象列に出力する
　～列ループここまで～
～行ループここまで～

以上のような流れで処理すれば、同じ社名を何度も検索する必要はなくなります。

この際、検索にMATCH関数を使ったのでは、やはりアンマッチの際にエラーが発生してしまいます。
FIND関数なら見つからなかった場合にNothingが取得されるので、これを利用する方法もありますが、そもそも何度もセル参照すること自体が処理を遅くする原因になります。

そこで今回はDictionalyを利用した方法をご紹介します。

最終的には上記の処理の流れで検索するのですが、その前に「元表」シートのキーとなる情報をディクショナリに格納します。
今回は検索したいものが「社名」と「項目名」の２つありますので、ディクショナリも２つ用意します。

社名ディクショナリには元表に存在する「社名」とその「行番号」を格納します。
こうしておくことで、社名ディクショナリに対して「社名」をキーとして検索をかけると、元表シートの「行番号」を取得することができるようになります。

同様に項目名ディクショナリにも元表に存在する「項目名」とその「列番号」を格納しておきます。

あとは転記先の行・列をループして、このディクショナリから元表シートの行番号・列番号を取り出すだけです。

以下、上記を実装したサンプルコードです。一部対象範囲の動的変更なども盛り込んでみました。

Sub 作成2()
    Const KENSAKU_CLM As Long = 2 '「転記先」シートＢ列
    Const KENSAKU_ROW As Long = 4 '「転記先」シート４行目
    
    Const MOTO_KEY_CLM As Long = 3 '「元表」シートのキー列（社名列：C列）
    Const MOTO_KEY_ROW As Long = 7 '「元表」シートのキー行（項目見出し行:７行目）
    
    Dim Sh_Moto As Worksheet    '「元表」シート
    Dim Sh_Tenki As Worksheet   '「転記先」シート
    
    'Dictionaryオブジェクトの宣言
    Dim dicShamei As Object     '元表の社名行番号ディクショナリ
    Dim dicKomoku As Object     '元表の項目名列番号ディクショナリ
    
    Dim iRRow As Integer        '元表シートの読込行
    Dim iRCol As Integer        '元表シートの読込列
   
    Dim iWRow As Integer        '転記先シートの出力行
    Dim iWCol As Integer        '転記先シートの出力列
    
    Set Sh_Moto = Worksheets("元表")
    Set Sh_Tenki = Worksheets("転記先")
    
    Set dicShamei = CreateObject("Scripting.Dictionary")
    Set dicKomoku = CreateObject("Scripting.Dictionary")
    
    '【ディクショナリ作成】
    '元表シートから社名のディクショナリを作成
    For iRRow = 8 To Sh_Moto.Cells(8, MOTO_KEY_CLM).End(xlDown).Row
        '社名をキーとして行番号をディクショナリに保管（同じ社名が複数存在した場合、後勝ちで行番号が上書きされます）
        dicShamei(Sh_Moto.Cells(iRRow, "C").Value) = iRRow
    Next
    '元表シートから項目名のディクショナリを作成
    For iRCol = 4 To Sh_Moto.Cells(MOTO_KEY_ROW, 4).End(xlToRight).Column
        '項目名をキーとして列番号をディクショナリに保管
        dicKomoku(Sh_Moto.Cells(7, iRCol).Value) = iRCol
    Next
    
    '【転記処理】
    '転記先シートの社名ループ
    For iWRow = 5 To Sh_Tenki.Cells(5, KENSAKU_CLM).End(xlDown).Row
        '社名から元表の行番号を取得
        If dicShamei.Item(Sh_Tenki.Cells(iWRow, KENSAKU_CLM).Value) = "" Then
            '社名から行番号が取得できない場合は何もしない
        Else
            '元表の行番号を取得
            iRRow = dicShamei.Item(Sh_Tenki.Cells(iWRow, KENSAKU_CLM).Value)
            
            '転記先シートの項目ループ
            For iWCol = 4 To Sh_Moto.Cells(KENSAKU_ROW, 4).End(xlToRight).Column
                '項目名から元表の列番号を取得
                If dicKomoku.Item(Sh_Tenki.Cells(KENSAKU_ROW, iWCol).Value) = "" Then
                    '項目名から列番号が取得できない場合は何もしない
                Else
                    '元表の列番号を取得
                    iRCol = dicKomoku.Item(Sh_Tenki.Cells(KENSAKU_ROW, iWCol).Value)
                    '「元表」シートの取得行・取得列のセルの値を、「転記先」シートの出力行・出力列に出力する
                    Sh_Tenki.Cells(iWRow, iWCol).Value = Sh_Moto.Cells(iRRow, iRCol).Value
                End If
            Next iWCol
        End If
    Next iWRow
    
End Sub

参考になれば幸いです。

Comments

[omotti]

いつもお世話になっております。
コードまで書いていただき本当にありがとうございます。

元々のエクセルにコードを貼り付けさせていただいて実行したのですが、
エラーなのか、固まってしまいました。
元表と転記表だけのブックで実行するときちんと動きますので、
なにが悪いのか調べてみます。

[omotti]

無事エラー解決しました。
今は理解できないのですが、よくよく勉強します。
大変ありがとうございました。

[jawa]

コメントを見るのが遅くなってしまいました。すみません。
解決はされたようですが、疑問も残っているようですので何か助言でも・・と思ったのですが、ブックの状態次第では正常な動作もしているようで。

そもそも読み書きする２つのシート以外に依存するような処理は記述していませんので、環境的な問題（メモリ不足など）なのか、ブックの問題（データ範囲が膨大とか、ブック自体が破損しているとか）なのか、ちょっといいアドバイスはできそうもありません。
申し訳ないです。

＞今は理解できないのですが、よくよく勉強します。
ネット検索などで得たコードを利用するのはよくあることですが、ただコピペするだけでは自分には何も残りません。
次もまた検索してコピペしなければならなくなりますし、アレンジもできないでしょう。

面倒でも、何をしているのか１行ずつ調べてみて、自分の知識として身に着けていってください。
頑張ってください。

[omotti]

コメントありがとうございます。

理由は分からないのですが、元表を一から作り直したら上手く作動しました。
元々のシートには、質問に載せました自作のコードを登録をしていたボタンを作っていまして、
そのボタンをなくしたら作動したので、それが原因なのかなと推測しています。

作っていただいたコードを使うことができて安心しました。
ありがとうございました。
勉強頑張ります。

Answer 2

正直、VBAでやるメリットが分かりません。

転記先のシートの１行目の数式を、
データ全体にコピペするくらいの手間を、
苦労してVBA化しても、小さな変化で動かなくなりますよ？

もちろん柔軟に作る事も可能ですが、
幾つもハードルがあります。

それに、もし自分がVBA作るとしても、
１行目に数式をセットしといて、
データ最終行までコピペさせます。

その方が簡単かつ調整しやすいからです。

なので、なぜVBAでやりたいのか、
その本当の目的を伝えないと
意味のある答えは返ってきにくいかと。

Comments

[omotti]

そうなんですか・・・

転記先の表は他の部署で作り、使用している表で、私は入力したものを提出しています。
ですので、転記先の表は勝手に数式を入れるなどの加工をせず、自動で転記できたらなと思いました。

初心者にはハードルが高いのでしたら、他の方法も考えます。
ありがとうございました。

[ExcelVBAer]

よくある部署間での摩擦ですね。

個人的には他部署も巻き込んで、
「数式セットするから、
　データをコピペするだけで良くなるよ？？」
と持ちかけてルールを変えてしまいますね~

じゃないと、延々と無駄な作業が残っていくので(汗)

こういった事柄はよくあることで、
「無理やり」対応する選択肢は無くはないですが、
システム化の流れとしては本末転倒かと。

また、他部署が関係するとなってくると、
様々なチェック機能を盛り込んでおかないと、
何かあった時（列が挿入、項目入れ替え etc）に、
自分だけ気づかず、後で怒られるということも。。。泣

まずは個人的な範囲で、
作業効率やチェックするツールを試してみてはいかがでしょうか？