Copy body of selected text to seperate work sheet when a certain word is found.

[thespider]

I don't know if this is possible. Is there are formula or process that this can be automated.
I have a sheet full of text. I would like to cut and past the data in between into separate sheets.

I have a sheet with lots of text. Every time the word "Question:" in a single cell appears. I would like to capture all the data below it and copy it to a separate sheet until the next word "Question" appears and for the process to repeat.
The example below I would like this sheet to be broken up into four separate sheets. Without doing it manually.

Question:
list children books
the boy that cried wolf
3little pigs

Question:
list of nusery rhymes
jack and jill
mary had a little lamb
3 bind mice:

Question:
colour of rainbow
yellow blue red

Question:
blah blah blah

 

[Peter_SSs]

Welcome to the MrExcel board!

Assuming that the data you have shown is in column A and that there is at least one blank row between each Question as it appears from your sample, then try this with a copy of your workbook.

Sub SplitQuestions()
  Dim rA As Range
  Dim i As Long
 
  Application.ScreenUpdating = False
  For Each rA In Columns("A").SpecialCells(xlConstants).Areas
    i = i + 1
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Q" & i
    rA.Copy Destination:=Sheets(Sheets.Count).Range("A1")
  Next rA
  Application.ScreenUpdating = True
End Sub

 

[thespider]

Welcome to the MrExcel board!

Assuming that the data you have shown is in column A and that there is at least one blank row between each Question as it appears from your sample, then try this with a copy of your workbook.

Sub SplitQuestions()
  Dim rA As Range
  Dim i As Long
 
  Application.ScreenUpdating = False
  For Each rA In Columns("A").SpecialCells(xlConstants).Areas
    i = i + 1
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Q" & i
    rA.Copy Destination:=Sheets(Sheets.Count).Range("A1")
  Next rA
  Application.ScreenUpdating = True
End Sub
[/QUOTE]

Welcome to the MrExcel board!

Assuming that the data you have shown is in column A and that there is at least one blank row between each Question as it appears from your sample, then try this with a copy of your workbook.

Sub SplitQuestions()
  Dim rA As Range
  Dim i As Long
 
  Application.ScreenUpdating = False
  For Each rA In Columns("A").SpecialCells(xlConstants).Areas
    i = i + 1
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Q" & i
    rA.Copy Destination:=Sheets(Sheets.Count).Range("A1")
  Next rA
  Application.ScreenUpdating = True
End Sub

Unfortunately this code use blanks in cells as the trigger and not the selective word.
It needs to trigger based on a selective text..... As there are plenty of blanks and random character in between...

 

[Peter_SSs]

It needs to trigger based on a selective text..... As there are plenty of blanks and random character in between...

Fair enough - you did say that at the start. however, some representative sample data (preferably with XL2BB ) usually helps clarify for people who are not familiar with your particular circumstances.

See how this one goes.

Sub SplitQuestions_v2()
  Dim fr As Long, lr As Long, i As Long
  Dim rFound As Range
  Dim bDone As Boolean
  
  Application.ScreenUpdating = False
  lr = Range("A" & Rows.Count).End(xlUp).Row + 1
  With Range("A1:A" & lr)
    Set rFound = .Find(What:="Question:", After:=.Cells(lr))
    If Not rFound Is Nothing Then
      Do
        fr = rFound.Row
        Set rFound = .FindNext(After:=rFound)
        If rFound.Row <= fr Then
          Set rFound = .Cells(lr)
          bDone = True
        End If
        i = i + 1
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Q" & i
        .Cells(fr).Resize(rFound.Row - fr).Copy Destination:=Sheets(Sheets.Count).Range("A1")
      Loop Until bDone
    End If
  End With
  Application.ScreenUpdating = True
End Sub