Paste values for entire row based on cell contents

[Janelle S]

Hi all

Hoping someone can help out. I want to paste the values in the entire row
based on the contents of one cell in that row.

Column Q is "Approved Status" with formula that is either Current or
Expired. When the formula changes to expired, the user activates a macro to
send an email with the expired cases. Expired then changes to Emailed. I
would like all the cells in that row to then be copied and pasted with their
values rather than the formula that exist in the other cells. This is the
macro I have so far - thanks to Ron DeBruin:

Sub Mail_Selection_Range_Outlook_Body()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2007

ActiveSheet.Unprotect
Selection.AutoFilter Field:=16, Criteria1:="expired"
Rows("2:2").Select
Range("B2").Activate
Selection.EntireRow.Hidden = True


Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object

Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng =
Sheets("Approvals").Range("b3:q20").SpecialCells(xlCellTypeVisible)

On Error GoTo 0


If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "CRCs Requiring New Approvals - Please Action"
.HTMLBody = RangetoHTML(rng)
.Display
End With
On Error GoTo 0

With Application
.EnableEvents = True
.ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing

Selection.AutoFilter Field:=16
Cells.Select
Range("B3").Activate
Selection.EntireRow.Hidden = False
Rows("1:1").Select
Range("B1").Activate
Selection.EntireRow.Hidden = True

ActiveSheet.Unprotect
Range("B3:U13").Select
Selection.sort Key1:=Range("Q4"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal



n = Cells(Rows.Count, "q").End(xlUp).Row
For i = 1 To n
With Cells(i, "q")
If .Value = "Expired" Then .Value = "Emailed"
End With
Next


ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowFiltering:=True
End Sub

 

[Sheeloo]

If you want to paste the row on itself then use the following;

Rows(i & ":" & i).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

It will paste row i on itself as values...

 

[Janelle S]

Thanks Sheeloo

How do I 'tell it' to only do this to the rows with "Emailed" in column Q.

 

[Sheeloo]

Put it inside the IF in your i loop which is already checking for the
condition.

 

[Janelle S]

Hi Sheeloo

I am obviously doing something majorly wrong. I have put it in - but the
result is all formula in the worksheet are replaced. I really appreciate your
help on this.

n = Cells(Rows.Count, "q").End(xlUp).Row
For i = 1 To n
With Cells(i, "q")
If .Value = "Expired" Then .Value = "Emailed"
Rows(i & ":" & i).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
skipBlanks:=False, Transpose:=False

End With
Next

 

[Sheeloo]

Try this
n = Cells(Rows.Count, "q").End(xlUp).Row
For i = 1 To n
With Cells(i, "q")
If .Value = "Expired" Then
..Value = "Emailed"
Rows(i & ":" & i).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
skipBlanks:=False, Transpose:=False
End IF

End With

The way you have written it, your IF ends on the line
If .Value = "Expired" Then .Value = "Emailed"

Notice that I have moved .Value = "Emailed" to the next line and added END
IF at the end

 

[Janelle S]

Thank you so much, Sheeloo. This works like a dream and your responses were
really quick too.

 

[FSt1]

n = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To n
With Cells(i, "A")
If .Value = "Expired" Then .Value = "Emailed"
If .Value = "Emailed" Then
.EntireRow.Copy
.PasteSpecial xlPasteValues
End If
End With
Next

regards
FSt1

 

[Sheeloo]

You are welcome.

Glad it solved your problem.