HI

I need a macro to copy row to another worksheet if cell is in bold
type.

Thanks

Andrea

Hi Andrea,

Try something like:

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
'<<============


---
Regards,
Norman


wrote in message
ups.com...
HI

I need a macro to copy row to another worksheet if cell is in bold
type.

Thanks

Andrea

Hi Norman

I wondered if this macro could be amended slightly to copy what the
header is for the total in bold.

I need it to go up one cell after it finds the bold cell and then to
the left and then copy the header row as well as the total.

I then planned to use a find macro if you think that would work to add
these into my Summary Sheet but I wouldnt know where to put it in your
code?

I've spent hours looking at this small part of my task.....I'm getting
no where.

Thanks so much for helping with this,

You are a star....

Andrea

On 2 Jun, 22:46, "Norman Jones"
wrote:
Hi Andrea,

Try something like:

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.CopyDestination:=destRng
End If

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

---
Regards,
Norman

wrote in message

ups.com...



HI

I need a macro tocopyrow toanotherworksheet if cell is inbold
type.

Thanks

Andrea- Hide quoted text -

- Show quoted text -