Finding Bold text and copying cells in column

[VBAmature31]

Hi all,

I have a report I am trying to filter and have come across a problem I am not able to solve!

Basically I am trying to find any cell that contains a font that in bold in column "D" and if found to copy that cell and also the cell to the right of it at the end of the worksheet,Please see my code below.

I have it working to the extent that it copies the bold cells but cannot get it to also copy the cell to the right.

Any help would be greatly appreciated.

Sub test()
Dim i As Long, LR As Long

LR = Range("d" & Rows.Count).End(xlUp).Row

For i = 1 To LR
If Range("d" & i).Font.Bold = True Then
Range("d" & i).Copy Destination:=Range("d" & Range("d" & Rows.Count).End(xlUp).Offset(1, 0).Row)
End If
Next i

End Sub

Thanks
KD

 

[NARAYANK991]

Hi ,

Change the following line to include the highlighted part.

Range("d" & i).Resize(1, 2).Copy Destination:=Range("d" & Range("d" & Rows.Count).End(xlUp).Offset(1, 0).Row)

Narayan

 

[VBAmature31]

Hi ,

Change the following line to include the highlighted part.

Range("d" & i).Resize(1, 2).Copy Destination:=Range("d" & Range("d" & Rows.Count).End(xlUp).Offset(1, 0).Row)

Narayan

Hi Narayan,

That has worked a treat,thank you so much,one last thing if you would be so kind,

The values I am copying to the right are formulas and when copied its returning a "0" value as opposed to the formula value.

Do you know how I can fix this?

Please see attached file

 

[NARAYANK991]

Hi ,

Replace the following segment of code :

    For i = 1 To LR
        If Range("d" & i).Font.Bold = True Then
            Range("d" & i).Resize(1, 2).Copy Destination:=Range("d" & Range("d" & Rows.Count).End(xlUp).Offset(1, 0).Row)
        End If
    Next i

by the following :

    For i = 1 To LR
        With Range("D" & i)
            If .Font.Bold = True Then
                .Copy Destination:=Range("d" & Range("d" & Rows.Count).End(xlUp).Offset(1, 0).Row)
                Range("d" & Range("d" & Rows.Count).End(xlUp).Row).Offset(, 1).Value = .Offset(, 1).Value
            End If
        End With
    Next i

Narayan

 

[VBAmature31]

Hi ,

Replace the following segment of code :

    For i = 1 To LR
        If Range("d" & i).Font.Bold = True Then
            Range("d" & i).Resize(1, 2).Copy Destination:=Range("d" & Range("d" & Rows.Count).End(xlUp).Offset(1, 0).Row)
        End If
    Next i

by the following :

    For i = 1 To LR
        With Range("D" & i)
            If .Font.Bold = True Then
                .Copy Destination:=Range("d" & Range("d" & Rows.Count).End(xlUp).Offset(1, 0).Row)
                Range("d" & Range("d" & Rows.Count).End(xlUp).Row).Offset(, 1).Value = .Offset(, 1).Value
            End If
        End With
    Next i

Narayan

Narayan,

Thank you so much I have been reading through my notes and posts to try and find the solution but couldn't get it....

This has worked perfect.

cheers!