VBA: Search in column for specific text and copy to another tab

[TaskMaster]

Hi all and thank you in advance for looking at my query. I have tried to make a start with this but getting nowhere.

I have a tab called data which I currently have to manually format copy and paste to another tab. In column where the first 4 characters in a cell is = to "FB09" I want to copy the last 8 characters data into another tab called summary starting in cell A23. Could anyone give me some suggestions.

 

[TaskMaster]

Is it just column S that you want to search for FB09 in?

Hi yes, sorry if my query was not clear.

 

[rlv01]

Ok. Try this

Sub FindAndCopyM()
    Dim WS1 As Worksheet, WS2 As Worksheet
    Dim R As Range, SearchRange As Range
    Dim S As String, SearchStr As String ,FirstAddr As String
    Dim LastRow As Long
    Dim FirstPass As Boolean

    Set WS1 = Worksheets("data")
    Set WS2 = Worksheets("summary")

    SearchStr = "FB09"

    Set SearchRange = WS1.Range("S1", WS1.Range("S" & WS1.Rows.Count).End(xlUp))

    With SearchRange
        Set R = .Find(what:=SearchStr, after:=.Cells(.Cells.Count), lookat:=xlPart, MatchCase:=True, searchdirection:=xlNext)
    End With

    If Not R Is Nothing Then
        FirstAddr = R.Address
        FirstPass = True
    End If

    Do While Not R Is Nothing
        If Not FirstPass Then
            Set R = SearchRange.Find(what:=SearchStr, after:=R, lookat:=xlPart, MatchCase:=True, searchdirection:=xlNext)
        End If

        If Not FirstPass Then
            If R.Address = FirstAddr Then
                Set R = Nothing
                Exit Do
            End If
        Else
            FirstPass = False
        End If
        
        If Not R Is Nothing Then
            If InStr(R.Value, SearchStr) = 1 Then
                S = Right(R.Value, 8)
                If WS2.Range("A23").Value = "" Then
                    WS2.Range("A23").NumberFormat = "@"
                    WS2.Range("A23").Value = S
                Else
                    With WS2
                        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
                         .Range("A" & LastRow + 1).NumberFormat = "@"
                        .Range("A" & LastRow + 1).Value = S
                    End With
                End If
            End If
        End If
    Loop
End Sub

 

[TaskMaster]

Ok. Try this

Sub FindAndCopyM()
    Dim WS1 As Worksheet, WS2 As Worksheet
    Dim R As Range, SearchRange As Range
    Dim S As String, SearchStr As String ,FirstAddr As String
    Dim LastRow As Long
    Dim FirstPass As Boolean

    Set WS1 = Worksheets("data")
    Set WS2 = Worksheets("summary")

    SearchStr = "FB09"

    Set SearchRange = WS1.Range("S1", WS1.Range("S" & WS1.Rows.Count).End(xlUp))

    With SearchRange
        Set R = .Find(what:=SearchStr, after:=.Cells(.Cells.Count), lookat:=xlPart, MatchCase:=True, searchdirection:=xlNext)
    End With

    If Not R Is Nothing Then
        FirstAddr = R.Address
        FirstPass = True
    End If

    Do While Not R Is Nothing
        If Not FirstPass Then
            Set R = SearchRange.Find(what:=SearchStr, after:=R, lookat:=xlPart, MatchCase:=True, searchdirection:=xlNext)
        End If

        If Not FirstPass Then
            If R.Address = FirstAddr Then
                Set R = Nothing
                Exit Do
            End If
        Else
            FirstPass = False
        End If
       
        If Not R Is Nothing Then
            If InStr(R.Value, SearchStr) = 1 Then
                S = Right(R.Value, 8)
                If WS2.Range("A23").Value = "" Then
                    WS2.Range("A23").NumberFormat = "@"
                    WS2.Range("A23").Value = S
                Else
                    With WS2
                        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
                         .Range("A" & LastRow + 1).NumberFormat = "@"
                        .Range("A" & LastRow + 1).Value = S
                    End With
                End If
            End If
        End If
    Loop
End Sub

This is perfect thank you