vba code for copying a string if it contains a certain value

Question

Hi I'm looking on how to edit my code so that instead of turning the font colour of the start of the string red and bold, it pastes these strings into another worksheet, however ever time I try to edit it I always end up with a run time error. Any help would be appreciated, here is my current code:

Sub colorText()

    Dim cl As Range
    Dim startPos As Integer
    Dim totalLen As Integer
    Dim searchText As String
    Dim endPos As Integer
    Dim testPos As Integer

     ' specify text to search.
     searchText = "(9)"

    ' loop trough all cells in selection/range
     For Each cl In Range("A:A")
      totalLen = Len(searchText)
      startPos = InStr(cl, searchText)
      testPos = 0

      Do While startPos > testPos
         With cl.Characters(startPos, totalLen).Font
          .FontStyle = "Bold"
          .ColorIndex = 3
         End With

    endPos = startPos + totalLen
    testPos = testPos + endPos
     startPos = InStr(testPos, cl, searchText, vbTextCompare)
  Loop

Next cl

End Sub

Answer 1

So according to what you said I assume this is what you are looking for? Your current code doesn't really make sense if the position of the SearchString within the String to search is not relevant as you said.

Sub CopyMatchedValuesToSheet()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim LastRowSource As Long, i As Long
Dim SearchString As String
Dim cell As Range

Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")

SearchString = "2" ' Set SearchString value or use the one below if you want to change it each time

'SearchString = Application.InputBox("Give a string", "SearchString", Type:=2)

i = 1

With ws1
    LastRowSource = .Cells.Find("*", [A1], , , xlByRows, xlPrevious).Row
    
    For Each cell In .Range("A1:A" & LastRowSource) ' Change to A2 if it has header
        If InStr(cell.Value, SearchString) > 0 Then
            ws2.Cells(i + 1, 1).Value = cell.Value
            i = i + 1
        End If
    Next cell
End With

End Sub

You can use the following to clear the Sheet2 each time just change the code to:

Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2") 
ws2.Cells.Clear