Copy Cells Based on Criteria in VBA

[bugsyb6]

I have a worksheet I'm using for tracking projects set up in a List (XL2003)
as follows:

A B C
1 Project Comments Status
2 Kaizen1 in process Active
3 CEDAC1 Active
4 CEDAC2 successful Complete

I am currently running the following code weekly to move the comments (or
lack of comments) to consecutive columns to the right of this beginning in
column F so that people can view comment history about a project but clear
the comment section for next week's input.

Sub MoveComments()

Range("B2:B4").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = " "
With Selection.Characters(Start:=1, Length:=1).Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Copy
Range("B2:B4").Copy
Range("BZ2").End(xlToLeft).Offset(, 1).PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
With Range("BZ1").End(xlToLeft).Offset(, 1)
.Value = Date
.NumberFormat = "mm/dd/yy"
End With
Range("B2:B4").ClearContents
Range("B2").Select
Application.CutCopyMode = False
End Sub

What I would like it to do is to move and clear the comments only from those
rows where the "Status" is listed as "Active" and leave the comments in
column B for those that are listed as "Complete".

Any help you can provide (as well as suggestions to clean up my existing
code) is greatly appreciated.

 

[Joel]

Sub MoveComments()

LastRow = Range("A" & Rows.Count).end(xlup).Row

with Range("B2:B4")
.SpecialCells(xlCellTypeBlanks).Select
.FormulaR1C1 = " "

With .Characters(Start:=1, Length:=1).Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
end with

LastCol = Cells(1,Columns.Count).End(xlToLeft).Column
For rowCount = 2 to LastRow
if Range("C" & RowCount) = "Active" then

Range("B" & RowCount).Copy
cells(RowCount, LastCol + 1).PasteSpecial _
Paste:=xlPasteValues
with cells(1, LastCol + 1)
.Value = Date
.NumberFormat = "mm/dd/yy"
End With
Range("B" & RowCount).ClearContents
end if
next rowcount
Range("B2").Select
Application.CutCopyMode = False
End Sub

 

[bugsyb6]

Joel -
Thanks for the quick reply, but there's just one issue. The data in B2:B4 is
cleared right after the .FormulaR1C1 = " " line of code runs so there is
nothing that is pasted. Any ideas what could be wrong?

bugsyb6

 

[Joel]

try this instead. I don't think you want to put a space in the blank cells.

Sub MoveComments()

LastRow = Range("A" & Rows.Count).end(xlup).Row

with Range("B2:B4").SpecialCells(xlCellTypeBlanks)

With .Characters(Start:=1, Length:=1).Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
end with

LastCol = Cells(1,Columns.Count).End(xlToLeft).Column
For rowCount = 2 to LastRow
if Range("C" & RowCount) = "Active" then

Range("B" & RowCount).Copy
cells(RowCount, LastCol + 1).PasteSpecial _
Paste:=xlPasteValues
with cells(1, LastCol + 1)
.Value = Date
.NumberFormat = "mm/dd/yy"
End With
Range("B" & RowCount).ClearContents
end if
next rowcount
Range("B2").Select
Application.CutCopyMode = False
End Sub