Copy row to another worksheet if a cell is bold

[iceyburnz]

I want to develop some VB that when triggered will copy a row to a new sheet if any of the cells in it are bold. I found the following code but it doesnt seem to work. Is anyone able to assist?
XP. Excel 2003


from: http://www.pcreview.co.uk/forums/macro-copy-row-another-worksheet-if-cell-bold-type-t3107494.html

Public Sub CopyRange()
Dim WB As Workbook
Dim srcSH As Worksheet
Dim destSH As Worksheet
Dim srcRng As Range
Dim rCell As Range
Dim copyRng As Range
Dim destRng As Range
Dim LRow As Long
Dim CalcMode As Long

Set WB = Workbooks("MyBook.xls") '<<=== CHANGE

With WB
Set srcSH = .Sheets("Sheet1") '<<=== CHANGE
Set destSH = .Sheets("Sheet2") '<<=== CHANGE
End With

Set srcRng = srcSH.Range("A1:A20") '<<==== CHANGE

With destSH
LRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set destRng = .Range("A" & LRow + 1)
End With

On Error GoTo XIT
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

For Each rCell In srcRng.Cells
If rCell.Font.Bold = True Then
If copyRng Is Nothing Then
Set copyRng = rCell
Else
Set copyRng = _
Union(rCell, copyRng)
End If
End If
Next rCell

If Not copyRng Is Nothing Then
copyRng.EntireRow.Copy Destination:=destRng
End If

XIT:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
End Sub

 

[venkat1926]

try this macro . data is in sheet1. result of macro is in sheet2

Sub test()
Dim r As Range, rcol As Range, c As Range, ccol As Range
Worksheets("sheet1").Activate
Set r = Range(Range("a1"), Cells(Rows.Count, "A").End(xlUp))
For Each c In r
Set rcol = Range(c, c.End(xlToRight))
For Each ccol In rcol
If ccol.Font.Bold = True Then
Rows(ccol.Row).Copy
With Worksheets("sheet2")
.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial
GoTo nextc
End With
End If
Next ccol
nextc:
Next c

End Sub