| 
    
     |  | ▼瞬希 さん: こんにちは。
 ▼かみちゃん さん:
 よこから 失礼します。
 
 Findメソッドの方法でも、書きだすだけならできないことはないと思います。
 なぜ多重検索になってしまうのか、原因は見つかりましたか?
 Findで見つかったらセルの書式を変えていますが、Do〜Loopのなかで
 書式のチェックがなされていないからですよね。
 書式を変えるのでもいいし、C列の範囲の値をいったん配列に退避しておいて、
 Do〜FindNext〜Loop の中では 見つかったセルをClearContents していっても
 いいと思います。(全セルの検索が終了したら 元の値を配列から書き戻します)
 
 >本当にしたい作業は
 >    C列    H列
 >    1    A+A
 >    2    B+B
 >    3    C+C
 >    4    D+D
 >    5    E+E
 >    6    F+F
 >と書き出すことなんです
 
 そういうときは Dictionaryオブジェクトを利用すると効率よいですよ。
 
 Sub Try2()
 Dim dic As Object
 Dim vC, vH, cc As Range
 Dim i As Long, n As Long
 Dim ss As String
 
 With Worksheets("sheet1")
 Set cc = .Range("C2", .Cells(Rows.Count, "C").End(xlUp))
 vC = cc.Value
 vH = cc.Offset(, 5).Value
 End With
 Set dic = CreateObject("Scripting.Dictionary")
 For i = 1 To UBound(vC)
 If Not IsEmpty(vC(i, 1)) Then
 ss = dic(vC(i, 1))
 If Len(ss) Then ss = ss & "+"
 ss = ss & vH(i, 1)
 dic(vC(i, 1)) = ss
 End If
 Next
 n = dic.Count
 With Worksheets("Sheet2")
 .Range("C2").Resize(n).Value = Application.Transpose(dic.Keys)
 .Range("H2").Resize(n).Value = Application.Transpose(dic.Items)
 End With
 Beep
 Set dic = Nothing
 End Sub
 
 |  |