Sub SetupOneTime()
'adds rectangle at top of each column
'code written by Dave Peterson 2005-10-22
'screwed around with by Jim Cone 2011-06-12
' so as to use buttons instead of rectangles.

Dim myRng As Range
Dim myCell As Range
Dim curWks As Worksheet
Dim myRect As Shape
Dim iCol As Integer
Dim iFilter As Integer
iCol = 7 'number of columns
iFilter = 14 'width of drop down arrow

Set curWks = ActiveSheet
With curWks
Set myRng = .Range("a1").Resize(1, iCol)
For Each myCell In myRng.Cells
With myCell
Set myRect = .Parent.Shapes.AddFormControl(xlButtonControl, _
Top:=.Top, Height:=.Height, _
Width:=.Width - iFilter, Left:=.Left)
End With
myRect.OnAction = ThisWorkbook.Name & "!SortTable"
myRect.TextFrame.Characters.Text = myCell.Value2
Next myCell
End With
End Sub
--
Jim Cone
Portland, Oregon USA
http://www.contextures.com/excel-sort-addin.html
editorial review of excel sorting add-in (30 ways to sort)




"Mr X Z"
wrote in message
...
Jim
I had been using Debra's brilliant site but for the life of me can't
explain why I hadn't look there!
It is exactly what I want except that I would prefer if the triangles
were replaced with command buttons that copied the cell entry as the
button name.
I have so far "lifted" this code below to use and despite many try's
can't work out how to incoporate it into Dave's code.
Be obliged if any one has any ideas.

Thank you for reading this.

ML


Sub CreateFormsButton()
Dim btn As Button
Dim rng As Range
With Worksheets("Sheet1")
Set rng = .Range("C1")
Set btn = .Buttons.Add(rng.Left, rng.Top, rng.Width, rng.Height)
With btn
.Caption = "Test"
.OnAction = "Test1"
End With
End With
End Sub

And Dave Petersons code


Sub SetupOneTime()

'adds rectangle at top of each column
'code written by Dave Peterson 2005-10-22
Dim myRng As Range
Dim myCell As Range
Dim curWks As Worksheet
Dim myRect As Shape
Dim iCol As Integer
Dim iFilter As Integer
iCol = 7 'number of columns
' 2010-Oct-31 added space for autofilter dropdowns
' set iFilter to 0 if not using autofilter
iFilter = 12 'width of drop down arrow

Set curWks = ActiveSheet

With curWks

Set myRng = .Range("a1").Resize(1, iCol)
For Each myCell In myRng.Cells
With myCell
Set myRect = .Parent.Shapes.AddShape _
(Type:=msoShapeRectangle, _
Top:=.Top, Height:=.Height, _
Width:=.Width - iFilter, Left:=.Left)
End With
With myRect
.OnAction = ThisWorkbook.Name & "!SortTable"
'' 2010-Oct-31 revised to fill shapes in Excel 2007
'' .Fill.Visible = False
.Fill.Solid
.Fill.Transparency = 1#
.Line.Visible = False
End With
Next myCell
End With
End Sub