Searh and Find VBA

[joseph_minner]

Hi!
Can someone please help. I have a macro that I have been using that searches for values in column K and it works great. However it searches only for the exact cell contents. I need it to be adjust to have it copy and paste the row if it contains the values. For example if I am searching for "73214" but the cell also has other values in it (for example 73214, 55645) it would still find it and copy it to another worksheet.

Here is the line that needs to be adjusted
'If value in column k = LSearchValue, copy entire row to Sheet2
If Range("k" & CStr(LSearchRow)).Value = LSearchValue Then
Thank you so much!

Sub SearchForString()

   Dim LSearchRow As Integer
   Dim LCopyToRow As Integer
   Dim LSearchValue As String

   On Error GoTo Err_Execute

   LSearchValue = InputBox("Please enter a value to search for.", "Enter value")

   'Start search in row 4
   LSearchRow = 2

   'Start copying data to row 2 in Sheet2 (row counter variable)
   LCopyToRow = 2

   While Len(Range("A" & CStr(LSearchRow)).Value) > 0

      'If value in column k = LSearchValue, copy entire row to Sheet2
      If Range("k" & CStr(LSearchRow)).Value = LSearchValue Then

         'Select row in Sheet1 to copy
         Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
         Selection.Copy

         'Paste row into Sheet2 in next row
         Sheets("Sheet2").Select
         Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
         ActiveSheet.Paste

         'Move counter to next row
         LCopyToRow = LCopyToRow + 1

         'Go back to Sheet1 to continue searching
         Sheets("Sheet1").Select

      End If

      LSearchRow = LSearchRow + 1

   Wend

   'Position on cell A3
   Application.CutCopyMode = False
   Range("A3").Select

   MsgBox "All matching data has been copied."

   Exit Sub

Err_Execute:
   MsgBox "An error occurred."

End Sub

 

[Fluff]

How about

Sub josephminner()
   Dim Cl As Range
   Dim LSearchValue As String
   
   LSearchValue = InputBox("Please enter a value to search for.", "Enter value")
   If LSearchValue = "" Then Exit Sub
   
   With Sheets("Sheet1")
      For Each Cl In .Range("K2", .Range("K" & Rows.Count).End(xlUp))
         If Cl.Value Like "*" & LSearchValue & "*" Then
            Cl.EntireRow.Copy Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
         End If
      Next Cl
   End With
End Sub

 

[joseph_minner]

You are so good!

 

[Fluff]

You're welcome & thanks for the feedback.