Previous Topic Next Topic

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

Closed
DonalK - May 16, 2017 at 08:57 AM
TrowaD
Posts
2886
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
June 27, 2022
 - May 22, 2017 at 12:04 PM
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.
Related:

2 replies

Answer 1 / 2
TrowaD
Posts
2886
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
June 27, 2022
 515
May 16, 2017 at 11:49 AM
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
0
DonalK
May 22, 2017 at 08:59 AM
Hi Trowa ,

Thanks for coming back to me, I have a spread sheet that includes entries like the below, ideally I would like a code to find Technical entry date, if the line below Is a number it would cut row the tech entry row and the next 3 rows below and paste into the next sheet, it the line below the tech entry date is a date I need it to cut the tech entry date and the 2 lines below and paste into the next sheet, I also need this to loop through so that they are all removed from sheet 1 and pasted into sheet 2. Hope that makes sense.

Thank you,


Technical entry date
0011111 Ms Joe Blogs
11/2016 ( 01.11.2016 - 30.11.2016 )
IENDD
Technical entry date
12/2016 ( 01.12.2016 - 31.12.2016 )
IENDD
0
Answer 2 / 2
TrowaD
Posts
2886
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
June 27, 2022
 515
May 22, 2017 at 12:04 PM
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
0