Solved: find, copy and paste

[Phelony]

Hi guys :hi:

I'm trying to build a find, copy and paste macro, sounds simple enough.
It should find the word "report" in column H from sheet 1 and then move it to a different sheet and paste that row into the next available empty row on sheet 3. :thumb

However, :dunno , all it seems to do at the moment is find the second instance of the word "report" and copy it into infinity....:banghead:

Don't suppose I could draw on your superness once more to give me a hand spotting the issue?

Dim lRealLastRow As Long
Sheets("Sheet1").Select
Cells.Find(What:="REPORT", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Range(Selection, Cells(ActiveCell.Row, 1)).Copy
Sheets("Sheet3").Select
Range("A:A").Select
Do While ActiveCell > 0
lineno = lineno + 1
ActiveCell.Offset(1, 0).Select
ActiveCell.PasteSpecial xlPasteValues
Loop

Been playing with it for ages, managed to stop it picking the first instance only due to a silly error, but I really can't figure out what I've done to mess it up this time!! :wot

Thanks

Phel x

[p45cal]

Re:"from sheet 1 and then move it to a different sheet "
please confirm you want to move rather than copy the row..
(coding for moving is easier than for copying because you don't have to worry so much about the After:= parameter in the Find statement.)

[Phelony]

It has to be copied I'm afraid, the original entry has to remain intact. What I'm trying to create is another list, but only of the items with "report" in column H.

[p45cal]

Do you have to do this a lot? That is, is it worth programming for? You could do all rows in one hit by adding an Autofilter, selecting 'Custom' in column H's dropdown, choosing the 'contains' option on the left, typing "report" (without quotes) on the right, then copy and paste the results to sheet 3.
(You can see I want to avoid coding for this one!)

[Phelony]

It forms a monthly report that will be built in also to provide an adhoc report function as part of a larger data migration macro. It also has to be applied to 36 different pages covering a year across three categories: doing a script that can then be applied to each page is the simplest way of doing it.

The current manual process takes several hours a week to do, an automated solution is definately the way forward.

This part of the script is only a small part of the complete project.

[p45cal]

This should get you started (I abandoned Find):Sub blah()
'With ActiveSheet
With ActiveWorkbook.Sheets("Sheet1")
For Each cll In Intersect(.UsedRange, .Columns("H"))
If InStr(UCase(cll.Value), "REPORT") > 0 Then
cll.EntireRow.Copy ActiveWorkbook.Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1)
End If
Next cll
End With 'activesheet
End SubAssumes column 1 (A) of destination will always contain something to designate an already occupied row, otherwise you'll get overwriting - see red 1 in the code above.

[Phelony]

Thanks for that, works a treat. :clap: Certainly cleared up one headache for this project!

Just out of curiosity, what was wrong with the Find function?

Phel x

[mdmackillop]

Find loops to the next item. Use the FindNext method.
From VBA Help


With Worksheets(1).Range("a1:a500")
Set c = .Find(2, lookin:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Value = 5
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With

[Phelony]

Which explains why it wasn't getting past the first entry....d'oh!

Thanks guys

Phel x

[mdmackillop]

Option Explicit
Option Compare Text
Sub CopyReport()
Dim C As Range, Tgt As Range
Dim FirstAddress As String
With Worksheets(1).Range("H:H")
Set C = .Find("Report", LookIn:=xlValues)
If Not C Is Nothing Then
FirstAddress = C.Address
Do
Set Tgt = Sheets(3).Cells(Rows.Count, "H").End(xlUp).Offset(1,-7)
C.EntireRow.Copy Tgt
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> FirstAddress
End If
End With
End Sub

[mdmackillop]

For Cut rather than Copy


Option Explicit
Option Compare Text
Sub CutReport()
Dim C As Range, Tgt As Range
Dim FirstAddress As String
With Worksheets(1).Range("H:H")
Do
Set C = .Find("Report", LookIn:=xlValues)
If Not C Is Nothing Then
Set Tgt = Sheets(3).Cells(Rows.Count, "H").End(xlUp).Offset(1).Offset(, -7)
C.EntireRow.Cut Tgt
End If
Loop While Not C Is Nothing
End With
End Sub