Gil
07-14-2011, 05:57 PM
Hello
What I am trying to do is to find text in a cell,copy row and paste into new sheet and then repeat. What I have so far copied from various sources and modified slightly is as follows
Option Explicit
Sub Donor1()
Dim n As Long, End_Row As Long
' Add a new sheet (will be called "Sheet1")
' Select the "Schedule" sheet as the active sheet
' Set a variable for the "end of file"
Sheets.Add
Sheets("Schedule").Select
End_Row = Range("A" & Rows.Count).End(xlUp).Row
' Find the first cell with the text to search for and activate the row
Rows.Find("DONOR", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=True).Activate
' Select "Sheet1" and paste the Copy data
' Then go to the next row in "Sheet1"
Selection.Copy
Sheets("Sheet1").Select
ActiveSheet.Paste
' Set a loop to repeat the Find Next command, Copy the row that is 2 rows
' above the found text and paste to the "Sheet1". Repeat until the end of file.
For n = 2 To End_Row
Sheets("Schedule").Select
Cells.FindNext(After:=ActiveCell).Activate
Selection.Copy
Sheets("Sheet1").Select
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Range("A1").Select
Sheets("Schedule").Select
Next n
End Sub
You will see from the attachment that it runs but only copies the word 'DONOR' and not the whole row (A:H) whether data is in the cells or not. It looks like the loop will not stop but after a few seconds it does. 'DONOR' is also pasted far too many times as well.
Please can someone point me in the right direction
What I am trying to do is to find text in a cell,copy row and paste into new sheet and then repeat. What I have so far copied from various sources and modified slightly is as follows
Option Explicit
Sub Donor1()
Dim n As Long, End_Row As Long
' Add a new sheet (will be called "Sheet1")
' Select the "Schedule" sheet as the active sheet
' Set a variable for the "end of file"
Sheets.Add
Sheets("Schedule").Select
End_Row = Range("A" & Rows.Count).End(xlUp).Row
' Find the first cell with the text to search for and activate the row
Rows.Find("DONOR", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=True).Activate
' Select "Sheet1" and paste the Copy data
' Then go to the next row in "Sheet1"
Selection.Copy
Sheets("Sheet1").Select
ActiveSheet.Paste
' Set a loop to repeat the Find Next command, Copy the row that is 2 rows
' above the found text and paste to the "Sheet1". Repeat until the end of file.
For n = 2 To End_Row
Sheets("Schedule").Select
Cells.FindNext(After:=ActiveCell).Activate
Selection.Copy
Sheets("Sheet1").Select
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Range("A1").Select
Sheets("Schedule").Select
Next n
End Sub
You will see from the attachment that it runs but only copies the word 'DONOR' and not the whole row (A:H) whether data is in the cells or not. It looks like the loop will not stop but after a few seconds it does. 'DONOR' is also pasted far too many times as well.
Please can someone point me in the right direction