Conditional Copy Routine

[PhilA]

I am trying to write a macro to search a column for a specific text string which when found, will copy the whole row the string is in. Once this row has been copied, I then want the macro to activate a new sheet and search for the next available empty row to paste the data. Once this has been done, go back to the original sheet and find the next cell in the original column with the specified text string and repeat until the range has been satisfied. Below is the script I have that sort of works.

Sub MoveLostJobs()

'
' Move Lost Jobs Macro
' Macro recorded 6 Oct 2009 by Phil Angove
'
Dim i As Integer
Dim j As Integer
Dim SheetName As String


SheetName = ActiveSheet.Name

For i = 71 To 86

    If Range("G" & i) = "Lost" Then

        Range("A" & i).Select
        Selection.EntireRow.Copy
        Sheets("Jobs Lost").Select

        j = 3

            If Range("A" & j) <> "" Then

            j = j + 1

            Else

        Range("A" & j).Select
        Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

        End If
    End If
    Next i

Sheets(SheetName).Select
End Sub

This script copies the row information and pastes it in the correct place but does not repeat for the next cell with "Lost" in it.

[PhilA]

Thank you Richard, I will try this when I get to work tomorrow and let you know how I get on.

D.O.

I will do my best to comply with the rules from now on.

Phil

[PhilA]

Hi Richard,

This script worked perfectly with just a slight bit of tweaking for my particular application (the from worksheet was variable depending on the user).

Thanks again for your help.

Phil

[DonkeyOte]

Sorry to be a pain - I should have mentioned this before... could you please re-title your thread also ? The thread title should be specific to the problem at hand - ie along the lines of what you "google" (you wouldn't google "VBA Question" for ex.)

To change a Title on your post, click EDIT on First Post then Go Advanced and change your title

Thanks

[Richard Schollar]

Hi Phil

Try the following code - it uses Autofilter which removes the need to loop (and can be very fast).

You will need to amend the wsFrom and wsTo names as indicated in the code, potentially the TO_FIND constant if you choose a different search term and also the Range (G71:G86 currently) if you wqant to extend the data rows being examined./

Sub copy_data()
Const TO_FIND = "Lost"  'amend as required
Dim rng As Range
Dim wsFrom As Worksheet, wsTo As Worksheet
Dim lngCalc As Long

With Application
    lngCalc = .Calculation
    .Calculation = xlCalculationManual
End With

Set wsFrom = Sheets("Sheet2")   'amend as appropriate (this is the name of the sheet you are copying data FROM)
Set wsTo = Sheets("Sheet1") 'amend as appropriate (this is the name of the sheet you are copying data TO)

With wsFrom
    .AutoFilterMode = False
    Set rng = .Range("G71:G86") 'this is the range  that contains the data - amend as appropriate
End With
With rng
    .Cells(1, 1).EntireRow.Insert
    .Offset(-1).Resize(1).Value = "TempHeader"
    .Resize(.Rows.Count + 1).Offset(-1).AutoFilter field:=1, Criteria1:=TO_FIND
    .EntireRow.Copy
    With wsTo.Cells(Rows.Count, "A").End(xlUp).Offset(1)
        .PasteSpecial xlPasteValues
        .PasteSpecial xlPasteFormats
    End With
    .AutoFilter
    .Offset(-1).Resize(1).EntireRow.Delete  'delete temp hdr row
End With

Application.Calculation = lngCalc

End Sub

Richard

[DonkeyOte]

Given Richard has gone to the lengths of providing a possible solution (and not wanting to waste his considerable efforts) I have on this occasion modified your thread title but I would ask that going forward you ensure your thread titles comply with the rules of the Forum.

Thanks in advance for your co-operation
D.O.