VBA code to find all cell in Col D in sheet 1 which contains cell value without match case from range A1 to A10 in Sheet 2

[deba2020]

I have 2 worksheets (Mysheet and Sheet1)
In Mysheet I have some partial text which the product description (column D) in Sheet1 has in it.
I want to loop through each items in Mysheet, locate each cell in Sheet1's Product Description (Col. D) that has that text, and then write the text from Mysheet in Sheet1's Col. C against each cell that contains that text.

I have this code but it is not giving desired results

Sub FindAndWrite()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim cell As Range, searchRange As Range, foundRange As Range

Set ws1 = ThisWorkbook.Sheets("Mysheet")
Set ws2 = ThisWorkbook.Sheets("Sheet1")
Set searchRange = ws1.Range("A1:A10")

For Each cell In searchRange
Set foundRange = ws2.Range("D:D").Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, searchdirection:=xlNext, MatchCase:=False)
If Not foundRange Is Nothing Then '
foundRange.Offset(0, -1).Value = "found"
End If
Next cell

End Sub

Please help.

Book12.xlsm
	C
1	Found Col
Sheet1

Book12.xlsm
	A
2	200 Silicone Fluid 200 cSt
Mysheet

 

[DanteAmor]

Hi @deba2020. Thanks for posting on MrExcel.

If more than one partial text matches in the sheet1 cell, then the macro adds it separated by a comma:

Sub FindAndWrite()
  Dim ws1 As Worksheet, ws2 As Worksheet
  Dim c As Range, r As Range, f As Range, searchRange As Range
  Dim cell As String
  
  Set ws1 = ThisWorkbook.Sheets("Mysheet")
  Set ws2 = ThisWorkbook.Sheets("Sheet1")
  Set searchRange = ws1.Range("A1:A10")
  Set r = ws2.Range("D:D")
  
  r.Offset(, -1).ClearContents
  For Each c In searchRange
    Set f = r.Find(c.Value, , xlValues, xlPart, , , False)
    If Not f Is Nothing Then
      cell = f.Address
      Do
        With f.Offset(0, -1)
          If .Value = "" Then .Value = c.Value Else .Value = .Value & ", " & c.Value
        End With
        Set f = r.FindNext(f)
      Loop While Not f Is Nothing And f.Address <> cell
    End If
  Next
End Sub

---------------------------------------------​

For example, in cell D7 there are 2 texts, so in cell C7 both results were placed.

Dante Amor
	C	D
1
2	text 1	text 1
3	text 1	x text 1
4	text 1	text 1 x
5	text 1	x text 1 x
6	text 2	text 2
7	text 1, text 2	text 2 text 1
8
Sheet1

Dante Amor
	A
1	text 1
2	text 2
3	text 3
4	text 4
5	text 5
6	text 6
7	text 7
8	text 8
9	text 9
10	text 10
Mysheet

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​

 

[Alex Blakenburg]

@DanteAmor - Hi Dante, just an FYI, although the microsoft web site gives the code you are using as their example the line below will fail if "f" is nothing.
The saving grace is that since we test for Is Nothing before getting there and we are only doing a find without a replace it will never be nothing at that point.

Loop While Not f Is Nothing And f.Address <> cell

 

[deba2020]

Thank you very much for your valuable help and opinion.
The code worked wonderfully and the results are exactly as desired.