VBA to find specific text and cut and past into new worksheet. Closed

Question

Hello, 

I am struggling to find anything to help me with my VBA code that I am currently trying to write. I need it to find specific text (Technical date of entry)  in column A , once it finds this text I need it to either cut that cell plus the next 2 or 3 cells below it depending on what is in the cell directly below it. 

So if it is a number below Technical date of entry) I need it to cut that cell plus the 3 below it.

If it is a date in the cell below technical date of entry I need it to cut that cell plus the 2 below it. 

and paste into the next sheet (Sheet1) 

Any help on this is greatly appreciated.

TrowaD · Answer

Hi DonalK,

I'm a little confused how many cells you want to cut.

First you say cut the cell with specific text and 2 or 3 cells below.

Then you say look at the cell below specific text and copy that cell (so the one below the specific text) and 2 or 3 cells below. That would mean; don't cut the specific text.

I went with the first one.

Give this code a try:
Sub RunMe()
Dim mFind As Range

Set mFind = Columns("A").Find("Technical date of entry")

If mFind Is Nothing Then
    MsgBox "There is no cell found with the text 'Technical date of " _
    & "entry' in column A of the active sheet."
    Exit Sub
End If

If IsDate(mFind.Offset(1, 0)) = True Then
    Range(mFind, Cells(mFind.Row + 2, "A")).Cut
    Sheets("Sheet1").Select
    Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
ElseIf WorksheetFunction.IsNumber(mFind.Offset(1, 0)) = True Then
    Range(mFind, Cells(mFind.Row + 3, "A")).Cut
    Sheets("Sheet1").Select
    Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select
    ActiveSheet.Paste
End If

End Sub

Best regards,
Trowa

TrowaD · Answer

Hi DonalK,

Quite a few changes. For the code to work make sure your source sheet is called Sheet1 and your destination sheet is called sheet2 (or change those reference in the code).

Give this code a try:
Sub RunMe()
Dim mFind As Range

Set mFind = Columns("A").Find("Technical entry date")

If mFind Is Nothing Then
    MsgBox "There is no cell found with the text 'Technical entry date'" _
    & " in column A of the active sheet."
    Exit Sub
End If

firstaddress = mFind.Address

Do
    If IsDate(mFind.Offset(1, 0)) = True Then
        Range(mFind, Cells(mFind.Row + 2, "A")).EntireRow.Cut
        Sheets("Sheet2").Select
        Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select
        ActiveSheet.Paste
    ElseIf WorksheetFunction.IsNumber(mFind.Offset(1, 0)) = True Then
        Range(mFind, Cells(mFind.Row + 3, "A")).EntireRow.Cut
        Sheets("Sheet2").Select
        Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select
        ActiveSheet.Paste
    End If
    
    Sheets("Sheet1").Select
    Set mFind = Columns("A").FindNext(mFind)
    If mFind Is Nothing Then Exit Sub
Loop While mFind.Address <> firstaddress

End Sub

Best regards,
Trowa

VBA to find specific text and cut and past into new worksheet.

2 responses

Similar discussions

Subscribe To Our Newsletter!