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.