PDA

View Full Version : Solved: Find text in a cell,copy row and paste into new sheet



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

mohanvijay
07-15-2011, 10:58 PM
try this


Dim last_row As Long, i As Long, j As Long
Dim sht As Worksheet

j = 1
Set sht = Sheets.Add

last_row = ThisWorkbook.Sheets("Schedule").Cells(Rows.Count, 1).End(xlUp).Row

For i = 1 To last_row
If UCase(ThisWorkbook.Sheets("Schedule").Cells(i, 1).Value) = "DONOR" Then
ThisWorkbook.Sheets("Schedule").Range("a" & i & ":h" & i).Copy ThisWorkbook.Sheets(sht.Name).Cells(j, 1)
j = j + 1
End If
Next i

Set sht = Nothing

p45cal
07-16-2011, 07:50 AM
ThisWorkbook.Sheets(sht.Name).Cells(j, 1)
is a long way of saying:
sht.Cells(j, 1)

Gil
07-18-2011, 06:44 PM
Hello
Sorry for the delay replying. With mohanvijay's code and the additional info from p45cal I now have the code that answers my original request.
If I may just ask for 2 more things

1. In the cell below 'DONOR' there is data that I would like to move to an empty cell in the same row as 'DONOR' prior to the copy & paste.

2. I would like the code to run on other worksheets other than the worksheet that contains the code.

Thank you for your support
Gil

CatDaddy
07-19-2011, 10:07 AM
2) User selected sheet

Dim sheetname As String
sheetname = inputbox("Sheet Name: ")

Multiple sheets
Dim sheetnames(1 to ActiveWorkbook.Sheets.Count) As String
Dim i as Long
Dim sht as WorkSheet
For each sht in ActiveWorkbook
sheetnames(i) = sht.Name
i = i+1
Next sht

Gil
07-19-2011, 07:16 PM
Hello
Many thanks CatDaddy for your suggestion. That works well but I also found that just changing ThisWorkbook to ActiveWorkbook produced the result I was after as well.

If anyone can suggest a solution for the last piece of the puzzle ie 1. In the cell below 'DONOR' there is data that I would like to move to an empty cell in the same row as 'DONOR' prior to the copy & paste.

I will then be able to close this thread.

CatDaddy
07-20-2011, 09:50 AM
Dim strAddress as String
strAddress = cellBelowDonor.Address

this will save the address of the cell you want