Copying Cells with a Partial String

[BobNewsome]

I have a macro where I'm trying to cut rows out of one sheet and place in another based on a partial data string in the cell.

Data:

1111-1000-8

1111-1001-8

1111-2000-8

1111-2000-8

1111-2001-8

<tbody>
</tbody>

Code:

Sub Macro1()'
Dim myrange As Range
Dim myvalue As String




myvalue = Range("A1:A2000").Find(What:="1111-2", LookIn:=xlFormulas)


'
    For Each Cell In Range("A1:A2000")
        If Cell.Value = myvalue Then
            If myrange Is Nothing Then
                Set myrange = Range(Cell.Address)
            Else
                Set myrange = Union(myrange, Range(Cell.Address))
            End If
        End If
    Next
    
    myrange.Select
    Selection.Cut

End Sub

The VBA is only finding the first 2 "1111-2000" but when the second qualifier changes ie "2001" it does not capture it. How do I get the code to capture ALL of the "1111-2" regardless of the next characters?

Thanks.

 

[Takae]

Hope this helps.
Please try floowing code after save your book.

Sub Macro1() '
    Dim myvalue As Range, FirstCell As Range, Target As Range
    
    Set myvalue = Range("A1:A2000").Find(What:="111-2*", LookIn:=xlFormulas)
    If myvalue Is Nothing Then
        MsgBox "NotFound"
        Exit Sub
    Else
        Set FirstCell = myvalue
        Set Target = myvalue
    End If
    Do
        Set myvalue = Range("A1:A2000").FindNext(myvalue)
        If myvalue.Address = FirstCell.Address Then
            Exit Do
        Else
            Set Target = Union(Target, myvalue)
        End If
    Loop
    Target.EntireRow.Delete
End Sub

 

[Fluff]

Another option

Sub chk()
   Dim Rng As Range
   With Range("A1", Range("A" & Rows.Count).End(xlUp))
      .Replace "1111-2", "=XXX1111-2", xlPart, , , , False, False
      Set Rng = .SpecialCells(xlFormulas, xlErrors)
      .Replace "=XXX1111-2", "1111-2", xlPart, , , , False, False
   End With
   Rng.Cut Sheets("[COLOR=#ff0000]New[/COLOR]").Range("A1")
End Sub

Change sheet name in red to suit

 

[BobNewsome]

Another option

Sub chk()
   Dim Rng As Range
   With Range("A1", Range("A" & Rows.Count).End(xlUp))
      .Replace "1111-2", "=XXX1111-2", xlPart, , , , False, False
      Set Rng = .SpecialCells(xlFormulas, xlErrors)
      .Replace "=XXX1111-2", "1111-2", xlPart, , , , False, False
   End With
   Rng.Cut Sheets("[COLOR=#ff0000]New[/COLOR]").Range("A1")
End Sub

Change sheet name in red to suit

Thank you Fluff! That worked slick......although I'm not sure why changing the data and then changing it back works, but it does

Thanks again!

 

[Fluff]

Glad to help & thanks for the feedback.
Changing the values in a formula (which will cause a formula error) allows the use of the specialcells method to find them.