Copy down if font = bold

[zljordan]

First off, I would like to thank everyone here for the wonderful insight y'all help to provide. This is an amazingly helpful resource to people all over the world, and I cannot thank you enough for it.

I am trying to create a macro that will search for the bold cells in column B, cut and paste to column C, and fill down until the next bold cell in column B is found. I have attached a sample work book with a desired result so you can get a better idea of what I am trying to do.

Thank you again!

[mancubus]

try this:

Sub vbax_53151_CopyDownBoldsBtoC()

    Dim i As Long
    Dim CopyStr As String
    
    For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
        If Cells(i, "B").Font.Bold = True Then
            CopyStr = Cells(i, "B").Value
            Cells(i, "B").Value = ""
        Else
            Cells(i, "C").Value = CopyStr
            Cells(i, "C").Font.Bold = True
        End If
    Next

End Sub

[mikerickson]

I think this will do what you want

Sub test()
    Dim SourceCell As Range
    Dim i As Long
    
    With Sheet1.Range("B:B")
        For i = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
            If .Cells(i, 1).Font.Bold Then
                If Not SourceCell Is Nothing Then
                    SourceCell.Copy Destination:=Range(SourceCell.Offset(1, 1), .Cells(i - 1, 2))
                    SourceCell.Clear
                End If
                Set SourceCell = .Cells(i, 1)
            End If
        Next i
        SourceCell.Copy Destination:=Range(SourceCell.Offset(1, 1), .Cells(i - 1, 2))
    End With
End Sub

[mikerickson]

This is a sturdier version

Sub test()
    Dim SourceCell As Range
    Dim i As Long
     
    With Sheet1.Range("B:B")
        .Offset(0, 1).Clear
        For i = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
            With .Cells(i, 1)
                If .Font.Bold Then
                    GoSub WriteBlock
                    Set SourceCell = .Cells(1, 1)
                End If
            End With
        Next i
        GoSub WriteBlock
    End With
Exit Sub
WriteBlock:
    If Not SourceCell Is Nothing Then
        With Sheet1.Range("B:B").Cells(i, 1)
            SourceCell.Copy Destination:=Range(SourceCell.Offset(Sgn((i - SourceCell.Row - 1)), 1), .Offset(-1, 1))
            SourceCell.Clear
        End With
    End If
    Return
End Sub

[zljordan]

mikerickson this worked beautifully. Thanks so much for your efforts...they are greatly appreciated.