copying bold cells to a new worksheet

[emitecaps]

Hi,

I have a column of data on sheet 1. For every cell in bold in column A I would like excel to copy the cell to sheet 2. I would also like to copy the cells in the three rows above to the next worksheet but have these appear in columns b, c, and d. In addition I would like to copy the cell 5 rows below, placing this in column e of the next worksheet

I've tried amending the following code but without success. Also, I'm trying to change the range function to include all cells with content in column a - so it's not fixed. I'm not sure if this is possible however.

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("nhs jobs usage.xls") '<<=== CHANGE

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

Set srcRng = srcSH.Range("A1:A2000")

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

Sorry, I know there is a lot here!
thanks

 

[JackDanIce]

Hi, I wasn't too keen on the code you provided so created this instead which works for me:

Public Sub ScrewYouGuysImGoingHome ()

Dim i As Long

With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
End With

With Sheets(1)
    For i = 1 To .Range("A" & Rows.Count).End(xlUp).Row
        If .Range("A" & i).Font.Bold And Len(.Range("A" & i)) > 0 Then
            .Range("A" & i).Copy
            Sheets(2).Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
            .Range("A" & i + 1 & ":A" & i + 3).Copy
            Sheets(2).Range("A" & Rows.Count).End(xlUp).Offset(0, 1).PasteSpecial Paste:=xlValues, Transpose:=True
            .Range("A" & i + 5).Copy
            Sheets(2).Range("A" & Rows.Count).End(xlUp).Offset(0, 4).PasteSpecial Paste:=xlValues
        End If
    Next i
End With

With Application
    .Calculation = xlAutomatic
    .ScreenUpdating = True
End With

End Sub

 

[JackDanIce]

The last 4 lines of code should be:

With Application
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
End With

End Sub

I missed out part of the word, please my suggested code as I left it too late to edit my original post

 

[emitecaps]

thanks - this works a treat!