find a value in a column then copy next few rows
 

Hi ther,e

I've got a doozy for everyone, I've got a spreadsheet with one column. The
data in the column is an extract of a large number of emails that get
generated through a group mailbox. What I'm trying to do is extract the body
data from those emails into a seperate worksheet to look at the data.

I've extracted the email to a txt file and it's in Excel, my first column
looks like this:

From:
Posted At:
Conversation:
Posted To:

Subject:

View Work Order
<http://www.homepage.com/123456

Comments:
This workorder needed a revision because of material delays

If you require further information,
please contact


The data repeats itself several hundred times.
What I would like to do is Extract all of the Comments and put it into a new
worksheet to look at why revisions were made.

I've been scowering the internet and I've got this snippit of code. It
presents a screen to the user to find a value. I enter "Comments:" then it
copies that line to another worksheet called sheet2.

I'm stuck trying to get it to search for the next cell below Comments that
contains the text "From:" and copy all of the cells inbetween to a new sheet.


Any ideas?

Thanks in advance.

Sub ExtractComments()
'
' ExtractComments Macro
' Macro recorded 23/05/2008 by Grant Ferdinands
'

Dim strLastRow As String
Dim rngC As Range
Dim strToFind As String, FirstAddress As String
Dim wSht As Worksheet
Dim rngtest As String
Application.ScreenUpdating = False

Set wSht = Worksheets("Sheet2")
strToFind = InputBox("Enter the value to find")

With ActiveSheet.Range("A1:A23331")
Set rngC = .Find(what:=strToFind, LookAt:=xlPart)
If Not rngC Is Nothing Then
FirstAddress = rngC.Address
Do
strLastRow = Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1
rngC.EntireRow.Copy wSht.Cells(strLastRow, 1)
Set rngC = .FindNext(rngC)
Loop While Not rngC Is Nothing And rngC.Address < FirstAddress
End If
End With

MsgBox ("Finished")

End Sub

find a value in a column then copy next few rows
 

This should do what you're looking for, if I understood you correctly,
let me know if you need it revised.

Sub MailFilter()

'Prompt User for Column with Data
Dim strcol As String
strcol = InputBox("What Column contains the data?", "Filter E-mail
Data", "A")

'Find the lastcell in the column with the text data
Dim lnglastrowcol As Long
lnglastrowcol = Range(strcol & "65536").End(xlUp).Row

'choose the range to be used
Dim rng As Range
Set rng = Range(strcol & "1", strcol & lnglastrowcol)

For Each c In rng
If InStr(1, c.Value, "Comments:") 0 Then
'find the cell with "From:"
Dim intcurrentrow As Integer
intcurrentrow = c.Row
Dim introwcount As Integer
introwcount = 0
Do Until InStr(1, c.Offset(introwcount, 0), "From:") 0 Or
introwcount = lnglastrowcol
'c.Offset(1, 0).Select
introwcount = introwcount + 1
Loop
'Select and copy the desired range
Range(strcol & intcurrentrow + 1, strcol & introwcount +
intcurrentrow - 1).Copy
'Paste to sheet 2 at the end of the last comment
Dim lnglastrow2 As Long
lnglastrow2 = Sheets(2).Range(strcol & "65536").End(xlUp).Row
ActiveSheet.Paste Destination:=Sheets(2).Range(strcol &
lnglastrow2 + 1)

End If
Next c

Range(strcol & "1").Select


End Sub

find a value in a column then copy next few rows
 

Sorry, it wrapped some lines, use this one"

Sub MailFilter()

'Prompt User for Column with Data
Dim strcol As String
strcol = InputBox("What Column contains the data?", _
"Filter E-mail Data", "A")

'Find the lastcell in the column with the text data
Dim lnglastrowcol As Long
lnglastrowcol = Range(strcol & "65536").End(xlUp).Row

'choose the range to be used
Dim rng As Range
Set rng = Range(strcol & "1", strcol & lnglastrowcol)

For Each c In rng
If InStr(1, c.Value, "Comments:") 0 Then
'find the cell with "From:"
Dim intcurrentrow As Integer
intcurrentrow = c.Row
Dim introwcount As Integer
introwcount = 0
Do Until InStr(1, c.Offset(introwcount, 0), "From:") 0 Or _
introwcount = lnglastrowcol
'c.Offset(1, 0).Select
introwcount = introwcount + 1
Loop
'Select and copy the desired range
Range(strcol & intcurrentrow + 1, strcol & introwcount + _
intcurrentrow - 1).Copy
'Paste to sheet 2 at the end of the last comment
Dim lnglastrow2 As Long
lnglastrow2 = Sheets(2).Range(strcol & "65536").End(xlUp).Row
ActiveSheet.Paste Destination:=Sheets(2).Range(strcol _
& lnglastrow2 + 1)

End If

find a value in a column then copy next few rows
 

After I added:

Next c

Range(strcol & "1").Select


End Sub

Only problem now is I get a run-time error '13':
Type Mismatch

When i debug it found this line in err.

Do Until InStr(1, c.Offset(introwcount, 0), "From:") 0 Or
introwcount = lnglastrowcol 'c.Offset(1, 0).Select


But it seemed like it copied everything I wanted into sheet2
Thanks!


"AndrewArmstrong" wrote:

Sorry, it wrapped some lines, use this one"

Sub MailFilter()

'Prompt User for Column with Data
Dim strcol As String
strcol = InputBox("What Column contains the data?", _
"Filter E-mail Data", "A")

'Find the lastcell in the column with the text data
Dim lnglastrowcol As Long
lnglastrowcol = Range(strcol & "65536").End(xlUp).Row

'choose the range to be used
Dim rng As Range
Set rng = Range(strcol & "1", strcol & lnglastrowcol)

For Each c In rng
If InStr(1, c.Value, "Comments:") 0 Then
'find the cell with "From:"
Dim intcurrentrow As Integer
intcurrentrow = c.Row
Dim introwcount As Integer
introwcount = 0
Do Until InStr(1, c.Offset(introwcount, 0), "From:") 0 Or _
introwcount = lnglastrowcol
'c.Offset(1, 0).Select
introwcount = introwcount + 1
Loop
'Select and copy the desired range
Range(strcol & intcurrentrow + 1, strcol & introwcount + _
intcurrentrow - 1).Copy
'Paste to sheet 2 at the end of the last comment
Dim lnglastrow2 As Long
lnglastrow2 = Sheets(2).Range(strcol & "65536").End(xlUp).Row
ActiveSheet.Paste Destination:=Sheets(2).Range(strcol _
& lnglastrow2 + 1)

End If

find a value in a column then copy next few rows
 

Thank you so much! I've been trying to get this darn thinking working forever!



One more thing though..... Any idea how to change the color of the cell
inbetween copies? or add some sort of "===========================" to the
cell to seperate the comments?


"AndrewArmstrong" wrote:

Sorry, it wrapped some lines, use this one"

Sub MailFilter()

'Prompt User for Column with Data
Dim strcol As String
strcol = InputBox("What Column contains the data?", _
"Filter E-mail Data", "A")

'Find the lastcell in the column with the text data
Dim lnglastrowcol As Long
lnglastrowcol = Range(strcol & "65536").End(xlUp).Row

'choose the range to be used
Dim rng As Range
Set rng = Range(strcol & "1", strcol & lnglastrowcol)

For Each c In rng
If InStr(1, c.Value, "Comments:") 0 Then
'find the cell with "From:"
Dim intcurrentrow As Integer
intcurrentrow = c.Row
Dim introwcount As Integer
introwcount = 0
Do Until InStr(1, c.Offset(introwcount, 0), "From:") 0 Or _
introwcount = lnglastrowcol
'c.Offset(1, 0).Select
introwcount = introwcount + 1
Loop
'Select and copy the desired range
Range(strcol & intcurrentrow + 1, strcol & introwcount + _
intcurrentrow - 1).Copy
'Paste to sheet 2 at the end of the last comment
Dim lnglastrow2 As Long
lnglastrow2 = Sheets(2).Range(strcol & "65536").End(xlUp).Row
ActiveSheet.Paste Destination:=Sheets(2).Range(strcol _
& lnglastrow2 + 1)

End If