Home |
Search |
Today's Posts |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Find specific column titles and copy the column to new workboo | Excel Programming | |||
Find specific column titles and copy the column to new workboo | Excel Programming | |||
Find all rows of a color and copy those rows to a new worksheet | Excel Programming | |||
Excel find text and copy rows | Excel Discussion (Misc queries) | |||
Copy Rows found using Find All feature | Excel Discussion (Misc queries) |