Range(cells,cells).findの使い方

Question

実現したいこと

Q2に書いてある特定の文字列A(櫛引橋上流)の右にある４つのセル(R2,S2,T2,U2)に存在する数字を、L列を検索してAと一致する文字列が存在する全ての行のG列,H列,I列,J列にコピーする。
全ての行にコピーが終わったら同様に、Q3に書いてある特定の文字列B(剣吉)の右にある４つのセル(R3,S3,T3,U3)に存在する数字を、L列を検索してBと一致する文字列が存在する全ての行のG列,H列,I列,J列にコピーする。
これを自動で繰り返し行えるようにしたいです。

具体的には、既にG2,H2,I2,J2にR2,S2,T2,U2をコピーしてしてありますが、
G3,H3,I3,J3～G13,H13,I13,J13 / G15,H15,I15,J15 / G17,・・・
にもR2,S2,T2,U2をコピーし、それが完了したら
R3,S3,T3,U3を G14,H14,I14,J14 / G16,・・・　にコピーし、
次にR4,S4,T4,U4を・・・
ということを、繰り返し自動で行いたい、ということです。説明が下手で申し訳ありません・・・。
自動化の案をお持ちの方はご教授いただければ幸いです。よろしくお願いいたします。

前提

ほぼ初心者です。
こちらのサイト様を参考にしてコードを考えてみたのですがエラーで動きませんでした。
https://vba-terakoya.com/get-cellnumber/

また、１００００行程度あるため手動でコピーすることは断念しました。

発生している問題・エラーメッセージ

アプリケーション定義またはオブジェクト定義のエラーです

該当のソースコード

Sub Sample2()
Dim i As Long
Dim k As Long
Dim D As String, Memo As Long
Dim buf As Long

  For i = 2 To 3
     'data.csvの情報をそれぞれ　D(日)、Memoに代入しておく
     D = Cells(i, 17)
     Memo1 = Cells(i, 18)
     Memo2 = Cells(i, 19)
     Memo3 = Cells(i, 20)
     Memo4 = Cells(i, 21)
     
     For k = 2 To 3
         '表の日と合致する行を探してmemoの内容を転記する
         buf = ReturnCellNum(D)
         Cells(buf, 7) = Memo1
         Cells(buf, 8) = Memo2
         Cells(buf, 9) = Memo3
         Cells(buf, 10) = Memo4
         
     Next k
         
  Next i

End Sub


Function ReturnCellNum(Name As String) As Long

  Dim FoundCell As Variant
  
  Set FoundCell = Range(Cells(k, 12), Cells(3, 12)).Find(Name)
  If FoundCell Is Nothing Then
      MsgBox "見つかりませんでした"
  Else
      ReturnCellNum = FoundCell.Row
  End If

試したこと

Sub Sample2()
Dim i As Long
Dim k As Long
Dim D As String, Memo As Long
Dim buf As Long

For i = 2 To 3
'data.csvの情報をそれぞれ　D(日)、Memoに代入しておく
D = Cells(i, 17)
Memo1 = Cells(i, 18)
Memo2 = Cells(i, 19)
Memo3 = Cells(i, 20)
Memo4 = Cells(i, 21)

’表の日と合致する行を探してmemoの内容を転記する
buf = ReturnCellNum(D)
Cells(buf, 7) = Memo1
Cells(buf, 8) = Memo2
Cells(buf, 9) = Memo3
Cells(buf, 10) = Memo4

Next i

End Sub

Function ReturnCellNum(Name As String) As Long

Dim FoundCell As Variant

Set FoundCell = Range("L1:L3").Find(Name)
If FoundCell Is Nothing Then
MsgBox "見つかりませんでした"
Else
ReturnCellNum = FoundCell.Row
End If

だと2行目にはコピーされるのですが、3行目にはコピーされずにループが終わってしまいます（その結果がスクショです）。

補足情報（FW/ツールのバージョンなど）

記載するコードには、動くかどうかのテストとしてループの数字から2 To 3にしてありますが、最終的には2 To 10000にしたいです。

Answer 1

Find、Findnextを使う案
参考　Findメソッド（Find,FindNext,FindPrevious）｜VBA入門 2023-11-23

Private Sub Codetest022()

Dim i As Long
Dim D As String
Dim buf As Long
Dim FoundCell As Variant
Dim FirstAddress As String
Dim 検索範囲 As Range

Set 検索範囲 = Range("L1:L19")

For i = 2 To 12
'data.csvの情報をそれぞれ　D(日)、Memoに代入しておく
D = Cells(i, 17)
Memo1 = Cells(i, 18)
Memo2 = Cells(i, 19)
Memo3 = Cells(i, 20)
Memo4 = Cells(i, 21)

'表の日と合致する行を探してmemoの内容を転記する
    Set FoundCell = 検索範囲.Find(D)
    
    If Not FoundCell Is Nothing Then
        FirstAddress = FoundCell.Address
        buf = FoundCell.Row
        
        Call Codetest022処理(buf, Memo1, Memo2, Memo3, Memo4)
        
        Do
            Set FoundCell = 検索範囲.FindNext(FoundCell)
            
'            Debug.Print FirstAddress & " / " & FoundCell.Address
            If FoundCell Is Nothing Then Exit Do
            If FoundCell.Address = FirstAddress Then Exit Do
            
            buf = FoundCell.Row
            
            Call Codetest022処理(buf, Memo1, Memo2, Memo3, Memo4)
            
            DoEvents
        Loop
    End If
Next i

End Sub
Private Sub Codetest022処理(buf As Long, Memo1 As Variant, Memo2 As Variant, Memo3 As Variant, Memo4 As Variant)

        Cells(buf, 7) = Memo1
        Cells(buf, 8) = Memo2
        Cells(buf, 9) = Memo3
        Cells(buf, 10) = Memo4

End Sub

ディクショナリ、配列を使う案

Private Sub Codetest019()

Dim ディクショナリ As Object
    Set ディクショナリ = CreateObject("Scripting.Dictionary")

Dim 行 As Long
Dim キー As String

    With Workbooks("hoge").Worksheets("huga")
        

        For 行 = 2 To .Cells(Rows.count, "Q").End(xlUp).Row
        
'            If Not ディクショナリ.exists(.Cells(行, "Q")) Then
                On Error GoTo Error1
                
                キー = .Cells(行, "Q").Value
                ディクショナリ.Add キー, 行
                
                On Error GoTo 0
'            End If
            
        Next
        

Dim コピー先配列()
        ReDim コピー先配列(2 To .Cells(Rows.count, "L").End(xlUp).Row, 1 To 4)
        
        For 行 = 2 To .Cells(Rows.count, "L").End(xlUp).Row
        
            キー = .Cells(行, "L")
            
            If ディクショナリ.exists(キー) Then
            
                コピー先配列(行, 1) = .Cells(ディクショナリ.Item(キー), "R")
                コピー先配列(行, 2) = .Cells(ディクショナリ.Item(キー), "S")
                コピー先配列(行, 3) = .Cells(ディクショナリ.Item(キー), "T")
                コピー先配列(行, 4) = .Cells(ディクショナリ.Item(キー), "U")
                
            End If
        
        Next
        
        .Cells(2, "G").Resize(UBound(コピー先配列, 1) - 1, UBound(コピー先配列, 2)) = コピー先配列
        
    End With
    
    Exit Sub
    
Error1:
    MsgBox "列Qに重複があります。"
    
    Stop
    
End Sub

Comments

[tatata1111]

ご回答いただきありがとうございました！ご教授いただいたコードで無事に動くことを確認できました。
元々の私のコードを活かした方法に加え、別の方法まで教えていただき大変勉強になりました。本当に助かりました！！

Answer 2

以下のようにしてください。
L列の文字がQ列にない場合は、そこで停止します。

Option Explicit


Public Sub 転記()
    Dim ws As Worksheet
    Dim dicT As Object
    Dim maxrow1 As Long
    Dim maxrow2 As Long
    Dim row1 As Long
    Dim row2 As Long
    Dim key As Variant
    Set ws = ActiveSheet
    Set dicT = CreateObject("Scripting.Dictionary")
    maxrow1 = ws.Cells(rows.Count, "L").End(xlUp).Row
    maxrow2 = ws.Cells(rows.Count, "Q").End(xlUp).Row
    For row2 = 2 To maxrow2
        key = ws.Cells(row2, "Q").Value
        dicT(key) = row2
    Next
    For row1 = 2 To maxrow1
        key = ws.Cells(row1, "L").Value
        If dicT.exists(key) = False Then
            MsgBox (key & "はQ列に存在しません")
            ws.Activate
            ws.Cells(row1, "L").Select
            Exit Sub
        End If
        row2 = dicT(key)
        ws.Cells(row1, "G").Resize(1, 4).Value = ws.Cells(row2, "R").Resize(1, 4).Value
    Next
    MsgBox ("完了")
End Sub

Comments

[tatata1111]

ご回答いただきありがとうございました！ご教授いただいたコードで無事に動くことを確認できました。
また、全く知らないコードを教えていただいたため大変勉強になりました。本当に助かりました！！