UserForms

Private Sub CancelButton_Click()

    Unload UserForm1

End Sub

 

Private Sub OKButton_Click()

    Dim workrange As Range

    On Error Resume Next

    Set workrange = seletion.SpecialCells(xlCellTypeConstants, xlCellTypeConstants)

    If OptionUpper Then

        For Each cell In workrange

            If Not cell.HasFormula Then

                cell.Value = UCase(cell.Value)

            End If

        Next

    End If

    If OptionLower Then

        For Each cell In workrange

            If Not cell.HasFormula Then

                cell.Value = LCase(cell.Value)

            End If

        Next

    End If

    If OptionProper Then

        For Each cell In workrange

            If Not cell.HasFormula Then

                cell.Value = Application.WorksheetFunction.Proper(cell.Value)

            End If

        Next

    End If

    Unload UserForm1

End Sub

 

Sub ChangeCase()

    If TypeName(Selection) = "Range" Then

        UserForm1.show

    End If

End Sub

 

Sub GetData()

    UserForm1.Show

End Sub

Private Sub CloseButton_Click()

    Unload UserForm1

End Sub

 

Private Sub EnterButton_Click()

    Dim nextrow As Long

    Sheets("sheet1").Activate

    nextrow = Application.WorksheetFunction.CountA(Range("A:A")) + 1

    If TextName.Text = "" Then

        MsgBox "you must enter a name"

        Exit Sub

    End If

    Cells(nextrow, 1) = TextName.Text

    If OptionMale Then Cells(nextrow, 2) = "Male"

    If OptionFemale Then Cells(nextrow, 2) = "Female"

    If OptionUnknown Then Cells(nextrow, 2) = "Unknown"

    Cells(nextrow + 1, 1).Activate

    OptionUnknown = True

    TextName.SetFocus

End Sub

---------------------------------------------------------------------------------------------------------------------

Private Sub Cancel_Click()

    Unload UserForm1

End Sub

Private Sub OK_Click()

    Dim Msg As String

‘    Multiselect is single

'    Msg = "you have selected item #"

'    Msg = Msg & (ListBox1.ListIndex) + 1

'    Msg = Msg & vbNewLine

'    Msg = Msg & ListBox1.Value

'    MsgBox Msg

'    Unload UserForm1

    Dim i As Integer

    Msg = " you have selected" & vbNewLine

    For i = 0 To ListBox1.ListCount - 1

        If ListBox1.Selected(i) Then

            Msg = Msg & ListBox1.List(i) & vbNewLine

        End If

    Next

    MsgBox Msg

    Unload UserForm1

    End Sub

 

Private Sub UserForm_Initialize()

    With ListBox1

        .AddItem "January"

        .AddItem "Feburary"

        .AddItem "March"

        .AddItem "April"

        .AddItem "May"

        .AddItem "June"

        .AddItem "July"

        .AddItem "August"

        .AddItem "september"

        .AddItem "October"

        .AddItem "November"

        .AddItem "December"

    End With

    ListBox1.ListIndex = 0

End Sub

Sub boldcells()

    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub

    ActiveCell.CurrentRegion.Select

    UserForm1.RefEdit1.Text = Selection.Address

    UserForm1.Show

End Sub

Private Sub CancelButton_Click()

    Unload UserForm1

End Sub

 

Private Sub OKButton_Click()

    On Error GoTo Badrange

    Range(RefEdit1.Text).Font.Bold = True

    Unload UserForm1

    Exit Sub

Badrange:

    MsgBox "The specified range is not valid."

End Sub

Private Sub CancelButton_Click()

    Unload UserForm1

End Sub

 

Private Sub OKButton_Click()

    Dim ctl As Control

    Dim Msg As String

    Msg = "You selected:" & vbNewLine

    For Each ctl In UserForm1.Controls

        If TypeName(ctl) = "OptionButton" Then

            If ctl.Value = True Then Msg = Msg & ctl.Caption & vbNewLine

        End If

    Next ctl

    MsgBox Msg

    Unload UserForm1

End Sub

Private Sub UserForm_Initialize()

    With SpinButton1

'       Specify upper and lower limits

        .Min = 1

        .Max = 100

'       Change label

        Label1.Caption = "Specify a value between " _

          & .Min & " and " & .Max & ":"

'       Initialize Spinner

        .Value = 1

'       Initialize TextBox

        TextBox1.Text = .Value

    End With

End Sub

 

Private Sub TextBox1_Change()

    Dim NewVal As Integer

    NewVal = Val(TextBox1.Text)

    If NewVal >= SpinButton1.Min And _

        NewVal <= SpinButton1.Max Then _

        SpinButton1.Value = NewVal

End Sub

 

Private Sub TextBox1_Enter()

'   Selects all text when user enters TextBox

    TextBox1.SelStart = 0

    TextBox1.SelLength = Len(TextBox1.Text)

End Sub

 

Private Sub SpinButton1_Change()

    TextBox1.Text = SpinButton1.Value

End Sub

 

 

Private Sub OKButton_Click()

'   Enter the value into the active cell

    If CStr(SpinButton1.Value) = TextBox1.Text Then

        ActiveCell = SpinButton1.Value

        Unload UserForm1

    Else

        MsgBox "Invalid entry.", vbCritical

        TextBox1.SetFocus

        TextBox1.SelStart = 0

        TextBox1.SelLength = Len(TextBox1.Text)

    End If

End Sub

UserDefined Functions

Function firstname()

    Dim fullname As String

    Dim fristspace As Integer

    fullname = Application.UserName

    firstspace = InStr(fullname, " ")

    If firstspace = 0 Then

        firstname = fullname

    Else

        firstname = Left(fullname, firstspace - 1)

    End If

    Range("a1") = firstname

End Function

Functions with no arguments Eg Rand, Today, Now

Function user()

    user = Application.UserName

End Function

A function with one argument

Function commission(sales)

    Dim Rate1 As Double, Rate2 As Double, Rate3 As Double, Rate4 As Double

    Rate1 = 0.08

    Rate2 = 0.105

    Rate3 = 0.12

    Rate4 = 0.14

    Select Case sales

        Case 0 To 9999.99: commission = sales * Rate1

        Case 10000 To 19999.99: commission = sales * Rate2

        Case 20000 To 39999.99: commission = sales * Rate3

        Case Is >= 40000: commission = sales * Rate4

    End Select

    commission = Round(commission, 2)

End Function

 

 

 

Starting Other Application from excel

Public Sub startcalculator2()

    Dim program As String

    Dim taskid As Double

    program = "calc.exe"

    On Error Resume Next

    AppActivate "calculator"

    If Err <> 0 Then

        Err = 0

        taskid = Shell(program, 1)

        If Err <> 0 Then MsgBox "cant start " & program

    End If

End Sub

Project explorer

Sub Openfolder()

    Dim program As String

    Dim folder As String

    program = "explorer.exe"

    folder = ThisWorkbook.Path

    Shell program & " " & folder, 1

End Sub