copy heading to each row

[Guest]

Hi,
Here's a problem I'm trying to solve

Background info...
I've been given several (10+) worksheets that I must now convert for use in
a database. The records are in rows but one of the key pieces of information
(the record's category field) is stored in it's own seperate row above the
records that belong in that category. Luckily, this header is bold so I think
I can iterate this column, looking for the bold proprty set to true. The
recordtext is plain (no bold, no italics).

My Plan
I want to iterate the cells in a colum, startign at the top. If I encounter
a cell with it's bold property set to true, I want to set a variable equal to
the contents of the bold cell. Then, move down to the next row and insert the
contents of the category variable to another cell. Repeat until I encounter
another bold cell or reach an empty cell. I would also like to delete the row
containing the headingas I process each worksheet.

Where can I find some sample code to assist me with this process. I have
been using VBA for several years but never in Excel. Any suggestions and/or
help is grealty appreciated.

 

[Dave Peterson]

Try this against a copy of your worksheet--it destroys the original version:

Option Explicit
Sub testme()
Dim myCell As Range
Dim myRng As Range
Dim DelRng As Range
Dim wks As Worksheet
Dim HeaderVal As Variant

Set wks = Worksheets("sheet1")
With wks
.Columns(1).Insert
Set myRng = .Range("b1", .Cells(.Rows.Count, "B").End(xlUp))

For Each myCell In myRng.Cells
If myCell.Font.Bold = True Then
HeaderVal = myCell.Value
If DelRng Is Nothing Then
Set DelRng = myCell
Else
Set DelRng = Union(myCell, DelRng)
End If
Else
myCell.Offset(0, -1).Value = HeaderVal
End If
Next myCell


If DelRng Is Nothing Then
'nothing found, so delete helper column
.Columns(1).Delete
Else
DelRng.EntireRow.Delete
End If
End With

End Sub

 

[Homer Simpson]

Thanks, Dave. That worked quite well!

Scott

Try this against a copy of your worksheet--it destroys the original
version:

Option Explicit
Sub testme()
Dim myCell As Range
Dim myRng As Range
Dim DelRng As Range
Dim wks As Worksheet
Dim HeaderVal As Variant

Set wks = Worksheets("sheet1")
With wks
.Columns(1).Insert
Set myRng = .Range("b1", .Cells(.Rows.Count, "B").End(xlUp))

For Each myCell In myRng.Cells
If myCell.Font.Bold = True Then
HeaderVal = myCell.Value
If DelRng Is Nothing Then
Set DelRng = myCell
Else
Set DelRng = Union(myCell, DelRng)
End If
Else
myCell.Offset(0, -1).Value = HeaderVal
End If
Next myCell


If DelRng Is Nothing Then
'nothing found, so delete helper column
.Columns(1).Delete
Else
DelRng.EntireRow.Delete
End If
End With

End Sub