Hi,
See the attached file which should be able to handle your large amount of SpinButtons.
How the Faux SpinButtons were created:
a. Create a Forms CommandButton or any Shape of your Choice. Remove text from the Shape if needed.
b. Create an AutoShape Triangle. Fill the triangle with the appropriate color. Rotate the triangle if needed.
c. Place the triangle inside the CommandButton. Change the shape sizes as required.
d. Right Click the First Shape and Select Order > Send to Back. This will make sure the Triangle is always visible.
e. Left Click the First Shape. Press the CTRL key and Left Click the Triangle.
f. Right Click the Green Circle on the Triangle and Select Grouping > Group.
To rename a grouped shape, 'Right Click' the grouped shape. Press ALT F8 to make the Macro menu visible. 'Double Click' on 'RenameActiveShape'.
Instructions for Creating Several Faux SpinButtons.
a. On Sheet 'Main', Create your cell structure such as exists on Row 3.
All cells should be the same size as the cells on row 2.
b. On Sheet 'Main', Create One MASTER Up Spin Button Group, and One Master Down SpinButton Group.
c. Put the Pair of Faux SpinButtons in Cell 'D2'.
d. Rename the UP Faux SpinButton In Cell 'D2' as 'FauxSpinUpD2' (using macro 'RenameActiveShape()'.
e. Rename the DOWN Faux SpinButton In Cell 'D2' as 'FauxSpinDownD2'.
f. At the top of Module 'ModShapeAsSpinButton', adjust the following items as required:
Public Const sFauxSpinButtonSheetName = "Main"
Public Const sFauxSpinButtonCells = "D2:D5"
Private Const nMinSpinButtonVALUE As Long = 0
Private Const nMaxSpinButtonVALUE As Long = 30000
g. Run macro CreateFauxSpinButtons() to create the 'Faux SpinButtons' (automatically runs the Delete routine).
h. Save the workbook. Done
How the Software Works:
a. Each 'Faux SpinButton' contains a 'Group Name' (e.g. FauxSpinUpD3') and individual 'Shape Names' (e.g. FauxSpinUpD3B')
that contain the Cell Address for the 'Faux SpinButton' (e.g. 'D3').
b. When an Up 'Faux SpinButton' is clicked, Event Handler FauxSpinUpEventHandler() is called.
c. When a Down 'Faux SpinButton' is clicked, Event Handler FauxSpinDownEventHandler() is called.
d. The Event Handler then calls ProcessFauxSpinButtonEvent() which will either increment or decrement the value in the cell to the left of the 'Faux SpinButton'.
Code module that process each 'Faux SpinButton' mouse click:
Option Explicit
Public Const sFauxSpinButtonSheetName = "Main"
Public Const sFauxSpinButtonCells = "D2:D5"
Private Const nMinSpinButtonVALUE As Long = 0
Private Const nMaxSpinButtonVALUE As Long = 30000
Sub ResetFauxSpinButtonLinkedCells()
'This resets Faux SpinButton 'Pseudo Linked Cell' values to 0 (ZERO)
'All Pseudo Linked Cells are one cell to the left of each cell in the range
Worksheets("Main").Range(sFauxSpinButtonCells).Offset(0, -1).Value = 0
End Sub
Sub FauxSpinUpEventHandler()
Call ProcessFauxSpinButtonEvent(1)
End Sub
Sub FauxSpinDownEventHandler()
Call ProcessFauxSpinButtonEvent(-1)
End Sub
Sub ProcessFauxSpinButtonEvent(iDelta As Long)
'This processes a 'Faux SpinButton' Event
'
'The 'Cell that contains the value is ASSUMED to be one cell to the left of the 'SpinButton'.
Dim r As Range
Dim c As String
Dim sCaller As String
Dim sCell As String
Dim sValueCell As String
'Get the name of the 'FauxSpinButton' or 'FauxSpinButton subordinate shape' that caused the event
sCaller = Application.Caller
'Remove the Main Part of the Shape Name to obtain the address of the 'Underlying Cell'
If iDelta = 1 Then
sCell = Replace(sCaller, "FauxSpinUp", "")
Else
sCell = Replace(sCaller, "FauxSpinDown", "")
End If
'Remove the Last Character of the Cell if it is NOT a number (e.g. 'D3A' becomes 'D3')
c = Right(sCell, 1)
If IsNumeric(c) = False Then
sCell = Left(sCell, Len(sCell) - 1)
End If
'Verify that the address is a VALID address
'Exit if the Address is NOT Valid (i.e. if a RUNTIME ERROR is generated)
On Error Resume Next
Set r = Range(sCell)
If r Is Nothing Then
GoTo MYEXIT
On Error GoTo 0
End If
On Error GoTo 0
'Set the focus on the 'Faux SpinButton' Cell
'This hides the cursor underneath the 'Faux SpinButton'
r.Select
'Get the address of the 'Value Cell' without '$' signs
'(one cell to the left of the cell that contains the 'Faux SpinButton')
sValueCell = Range(sCell).Offset(0, -1).Address(False, False)
Set r = Range(sValueCell)
'MsgBox "ProcessFauxSpinButtonEvent():" & vbCrLf & _
"SpinButton Cell '" & sCell & "'" & vbCrLf & _
"Value Cell '" & sCell & "'" & vbCrLf & _
"Delta = " & iDelta & vbCrLf & _
"Old Value = " & r.Value & vbCrLf & _
"New Value = " & r.Value + iDelta
'Increment or Decrement the Value Cell
r.Value = r.Value + iDelta
'Make sure the Value is within the defined range
If r.Value < nMinSpinButtonVALUE Then
r.Value = nMinSpinButtonVALUE
ElseIf r.Value > nMaxSpinButtonVALUE Then
r.Value = nMaxSpinButtonVALUE
End If
MYEXIT:
'Clear object pointers
Set r = Nothing
End Sub
Code module used during software development to create and/or access the 'Faux SpinButtons':
Option Explicit
Sub CreateFauxSpinButtons()
'This creates 'Faux Spinbutton' Shapes on the Designated Sheet from MASTER SPINBUTTONS
'
'Group Shapes are created of the form:
'a. 'FauxSpinUpD3'
'b. 'FauxSpinDownD3'
' where 'D3' is the cell that contain the 'Faux SpinButton'
'
'Subordinate Shapes in each group are created of the form:
'a. 'FauxSpinUpD3A' 'FauxSpinUpD3B'
'b. 'FauxSpinDownD3A' 'FauxSpinDownD3B'
' where the last character is a DIFFERENT letter for each shape
Dim Sh As Object
Dim r As Range
Dim mySourceShape1 As Object
Dim mySourceShape2 As Object
Dim myDestinationShape As Object
Dim i As Long
Dim iCount As Long
Dim xLeft As Double
Dim xTop As Double
Dim xHeightSource As Double
Dim sAddress As String
Dim sName As String
Dim sNewShapeName As String
Dim sShapeName As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Delete Existing 'Faux SpinButton' Shapes (except the Master)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Call DeleteAllFauxSpinButtonsExceptMaster
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Create the Shapes
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Process each Cell in the Range
For Each r In Sheets(sFauxSpinButtonSheetName).Range(sFauxSpinButtonCells)
'Increment the Cell Counter
iCount = iCount + 1
If iCount = 1 Then
'The first cell contains the MASTER SPINBUTTONS
'Create the Source Objects
'Get the Height of the 'Up Master Faux SpinButton'
Set mySourceShape1 = Sheets(sFauxSpinButtonSheetName).Shapes("FauxSpinUpD2")
'Debug.Print mySourceShape1.Name
xHeightSource = mySourceShape1.Height
Set mySourceShape2 = Sheets(sFauxSpinButtonSheetName).Shapes("FauxSpinDownD2")
'Debug.Print mySourceShape2.Name
Else
'Get the address of the Destination Cell (with no '$' signs)
'Get the location of the 'Top Left' Corner of the Destination Cell
sAddress = r.Address(False, False)
xLeft = r.Left
xTop = r.Top
'Create the Up 'Faux SpinButton'
'Change the name to include the Cell Address
'Position the 'Faux Spinbutton'
'Add the Event Handler Name (OnAction Text)
Set myDestinationShape = mySourceShape1.Duplicate
myDestinationShape.Name = "FauxSpinUp" & sAddress
myDestinationShape.Left = xLeft + 1
myDestinationShape.Top = xTop + 1
myDestinationShape.OnAction = "FauxSpinUpEventHandler"
'Create the Down 'Faux SpinButton'
'Change the name to include the Cell Address
'Position the 'Faux Spinbutton'
'Add the Event Handler Name (OnAction Text)
Set myDestinationShape = mySourceShape2.Duplicate
myDestinationShape.Name = "FauxSpinDown" & sAddress
myDestinationShape.Left = xLeft + 1
myDestinationShape.Top = xTop + xHeightSource + 1
myDestinationShape.OnAction = "FauxSpinDownEventHandler"
End If
Next r
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Rename the Subordinate Shapes in Each Group
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For Each Sh In ActiveSheet.Shapes
sName = Sh.Name
If UCase(Left(sName, Len("FauxSpin"))) = "FAUXSPIN" And Sh.Type = msoGroup Then
'Debug.Print sName
If Sh.GroupItems.Count > 0 Then
For i = 1 To Sh.GroupItems.Count
sShapeName = Sh.GroupItems(i).Name
sNewShapeName = sName & LjmExcelColumnNumberToChar(i)
Sh.GroupItems(i).Name = sNewShapeName
'Debug.Print " " & sNewShapeName
Next i
End If
End If
Next Sh
End Sub
Sub IterateThruFauxSpinButtons()
'This iterates through 'Faux Spinbutton' Shapes on the ActiveSheet in the Immediate Window (CTRL G)
Dim Sh As Object
Dim i As Long
Dim iCount As Long
Dim sName As String
Dim sShapeName As String
Debug.Print
Debug.Print "Faux SpinButton List as of " & Now()
For Each Sh In ActiveSheet.Shapes
sName = Sh.Name
If UCase(Left(sName, Len("FauxSpin"))) = "FAUXSPIN" And Sh.Type = msoGroup Then
iCount = iCount + 1
Debug.Print Format(iCount, "000 ") & _
Format(Sh.Name, "!@@@@@@@@@@@@@@ ") & _
Format(Sh.Top, "@@@@@@@ ") & _
Format(Sh.Left, "@@@@@@@ ") & _
Format(Sh.Width, "@@@@@@@ ") & _
Format(Sh.Height, "@@@@@@@ ") & _
Format(Sh.OnAction, "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ ")
If Sh.GroupItems.Count > 0 Then
For i = 1 To Sh.GroupItems.Count
sShapeName = Sh.GroupItems(i).Name
Debug.Print " " & sShapeName
Next i
End If
End If
Next Sh
If iCount = 0 Then
Debug.Print "There were NO Faux SpinButton Shapes to Iterate through on the ActiveSheet."
End If
End Sub
Sub DeleteAllFauxSpinButtonsExceptMaster()
'This deletes all 'Faux Spinbutton' Shapes on the Designated Sheet EXCEPT the MASTER SPINBUTTONS
Dim r As Range
Dim iCount As Long
Dim sAddress As String
Dim sShapeName As String
'Process each Cell in the Range
'Ignore Runtime Errors (in case the 'Faux SpinButtons' don't exist)
On Error Resume Next
For Each r In Sheets(sFauxSpinButtonSheetName).Range(sFauxSpinButtonCells)
'Increment the Counter
iCount = iCount + 1
'Do not process the first Set of 'Faux SpinButtons' (the Master Set)
If iCount > 1 Then
'Get the cell address (with no '$' signs)
sAddress = r.Address(False, False)
'Create the 'Up' Shape Name (includes the Cell Address)
'Delete the Shape
sShapeName = "FauxSpinUp" & sAddress
Sheets(sFauxSpinButtonSheetName).Shapes(sShapeName).Delete
'Create the 'Down' Shape Name (includes the Cell Address)
'Delete the Shape
sShapeName = "FauxSpinDown" & sAddress
Sheets(sFauxSpinButtonSheetName).Shapes(sShapeName).Delete
End If
Next r
On Error GoTo 0
End Sub
Sub RenameActiveShape()
'This renames the 'Active Shape' (new name is obtained via 'InputBox')
Dim sData As String
Dim sOldShapeName As String
Dim sName As String
Dim sNewShapeName As String
'Get the name of the 'Active Shape'
'Exit if there is none
On Error Resume Next
sOldShapeName = Application.Selection.Name
If Err.Number <> 0 Then
MsgBox "There is no Active Shape selected."
GoTo ERROR_EXIT
End If
'Get the new 'Shape Name' (without leading and trailing BLANKS)
sData = "Enter the New Name for Shape '" & sOldShapeName & "'" & vbCrLf & _
"then Select 'OK'"
sNewShapeName = InputBox(sData, "Shape Rename")
sNewShapeName = Trim(sNewShapeName)
'Verify that the name isn't BLANK
If Len(sNewShapeName) = 0 Then
MsgBox "Nothing done. The new Name is BLANK or CANCEL was selected." & vbCrLf & _
"Try again with a name that is Unique on the Sheet."
GoTo ERROR_EXIT
End If
'Verify that the name does not already exist
'No error means the name already exists
sName = ActiveSheet.Shapes(sNewShapeName).Name
If Err.Number = 0 Then
MsgBox "Nothing done. New Name '" & sNewShapeName & "' already exists." & vbCrLf & _
"Try again with a name that is Unique on the Sheet."
GoTo ERROR_EXIT
End If
'Rename the Shape
ActiveSheet.Shapes(sOldShapeName).Name = sNewShapeName
'Display a Message
MsgBox "The Active Shape was renamed." & vbCrLf & _
"Old Name: '" & sOldShapeName & "'" & vbCrLf & _
"New Name: '" & sNewShapeName & "'"
ERROR_EXIT:
On Error GoTo 0
End Sub
''''''''''''''''''''''''''''''''''''''''
'Utility Routines
''''''''''''''''''''''''''''''''''''''''
Function LjmExcelColumnNumberToChar(InputColumn As Long) As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' This converts an Excel integer column number to "character column letter(s)"
' e.g. convert 1 to "A"
' e.g. convert 28 to "AB"
'
' This assumes 2 character column limitation of 702 columns = (26 * 27)
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If InputColumn > 26 Then
LjmExcelColumnNumberToChar = Chr(Int((InputColumn - 1) / 26) + 64) & Chr(((InputColumn - 1) Mod 26) + 65)
Else
LjmExcelColumnNumberToChar = Chr(InputColumn + 64)
End If
End Function
Please let me know if you have any questions and/or problems and/or additional help.
Lewis
LinkBack URL
About LinkBacks
Register To Reply
. This is highly accurate. 
Bookmarks