如果单元格包含某些文本，则复制文本的一部分并移至新表

Question

Im trying to use VBA in order to detect cells which contain the word HELLO and then:

take the 7th to 10th characters and copy those to a new sheet on the first available row

then copy the 12th to last character to a second column on the new sheet.

Repeat for all cells containing the phrase.

Right now I can't get the code to copy the first cell that contain the phrase.

This is the current code:

Sub test()
Dim LR As Long, i As Long
With Sheets("Sheet1")
LR = .Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To LR
    If .Range("A" & i) Like "*HELLO*" Then
    .Copy Mid(Range("A" & i), 2, 2)

Next i
End Sub

Answer 1

Instead of copying, it would be better just to assign the partial string value into the next cell in the second sheet. I also added UCASE to your if statement in case the HELLO isn't capitalized. Then added an If to check if the string was 12 characters long atleast before returning the 12th to last character.

Sub test()
Dim LR As Long, i2 As Long


LR = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
i2 = 1

For i = 1 To LR
    If UCase(Sheets(1).Range("A" & i).Value) Like "*HELLO*" Then
        Sheets(2).Range("A" & i2).Value = Mid(Sheets(1).Range("A" & i).Value, 7, 3)
        If Len(Sheets(1).Range("A" & i).Value) > 11 Then
            Sheets(2).Range("B" & i2).Value = Mid(Sheets(1).Range("A" & i).Value,13, Len(Sheets(1).Range("A" & i).Value) - 12)
        End If
        i2 = i2 + 1
    End If
Next i

End Sub

Answer 2

You probably can't copy it, you may have yo just place it in another cell location something like

Sub Button1_Click()

    Dim LR As Long, i As Long
    With Sheets("Sheet1")
        LR = .Range("A" & Rows.Count).End(xlUp).Row
        For i = 1 To LR
            If .Range("A" & i) Like "*HELLO*" Then
                Cells(Rows.Count, "C").End(xlUp).Offset(1, 0) = Mid(Range("A" & i), 2, 2)
            End If
        Next i
    End With
End Sub

Edit: Ah, somebody else had the same idea.