' Excelpro.ir
' Hamed Ghadimi
' VBA Practice Codes

'Option Explicit
'Option Base 0
'Option Base 1
'Option Compare Binary
'Option Compare Text
'Option Private Module

 

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''Variable & Constant Definition
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub VariableDefinition()
Dim x As Integer, y As Integer, z As Integer
Dim First As Long, Last As Double
Const NumQuarters As Integer = 4
Const Rate = 0.0725, Period = 12
Const ModName As String = "Budget Macros"
Const AppName As String = "Budget Application"
Dim MyArray(1 To 100) As Integer
Dim MyArray(1 To 10, 1 To 10) As Integer
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub ShowRoot()
    Dim MyValue As Double
    Dim SquareRoot As Double
    MyValue = 25
    SquareRoot = Sqr(MyValue)
    MsgBox SquareRoot
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub ShowRoman()
    Dim DecValue As Long
    Dim RomanValue As String
    DecValue = 1939
    RomanValue = Application.WorksheetFunction.Roman(DecValue)
    MsgBox RomanValue
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub MySub()
Static Counter As Integer
Dim Msg As String
Counter = Counter + 1
Msg = "Number of executions: " & Counter
MsgBox Msg
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub CheckForFormulas()
Dim FormulaTest As Variant
FormulaTest = Range("A1:A2").HasFormula
If TypeName(FormulaTest) = "Null" Then
MsgBox "Mixed!"
Else
MsgBox FormulaTest
End If
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub VariantDemo2()
    MyVar = "123"
    MsgBox TypeName(MyVar)
    MyVar = MyVar / 2
    MsgBox TypeName(MyVar)
    MyVar = "Answer: " & MyVar
    MsgBox TypeName(MyVar)
    MsgBox MyVar
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''User-Defined Variable Definition
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Type CustomerInfo
    Company As String
    Contact As String
    RegionCode As Long
    Sales As Double
End Type
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''Msgbox Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub GuessName()
    Msg = "Is your name " & Application.UserName & "?"
    Ans = MsgBox(Msg, vbYesNo)
    If Ans = vbNo Then MsgBox "Oh, never mind."
    If Ans = vbYes Then MsgBox "I must be psychic!"
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub GetAnswer4()
    Dim Msg As String, Title As String
    Dim Config As Integer, Ans As Integer
    Msg = "Do you want to process the monthly report?"
    Msg = Msg & vbNewLine & vbNewLine
    Msg = Msg & "Processing the monthly report will "
    Msg = Msg & "take approximately 15 minutes. It "
    Msg = Msg & "will generate a 30-page report for "
    Msg = Msg & "all sales offices for the current "
    Msg = Msg & "month."
    Title = "XYZ Marketing Company"
    Config = vbYesNo + vbQuestion
    Ans = MsgBox(Msg, Config, Title)
    If Ans = vbYes Then
    Debug.Print "OK"
    End If
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''InputBox Function & Method
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub CheckUser2()
    UserName = InputBox("Enter Your Name: ")
    If UserName = "Steve Ballmer" Then
        MsgBox ("Welcome Steve...")
'      ...[More code here] ...
    Else
        MsgBox "Sorry. Only Steve Ballmer can run this."
    End If
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub GetName()
    Dim TheName As String
    TheName = InputBox("What is your name?", _
       "Greetings", Application.UserName)
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub AddSheets()
    Dim Prompt As String
    Dim Caption As String
    Dim DefValue As Integer
    Dim NumSheets As String
    Prompt = "How many sheets do you want to add?"
    Caption = "Tell me..."
    DefValue = 1
    NumSheets = InputBox(Prompt, Caption, DefValue)
    If NumSheets = "" Then Exit Sub 'Canceled
    If IsNumeric(NumSheets) Then
        If NumSheets > 0 Then Sheets.Add Count:=NumSheets
    Else
        MsgBox "Invalid number"
    End If
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub GetRange()
    Dim Rng As Range
    On Error Resume Next
    Set Rng = Application.InputBox _
      (Prompt:="Specify a range:", Type:=8)
    If Rng Is Nothing Then Exit Sub
    MsgBox "You selected range " & Rng.Address
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub GetValue2()
    Dim UserEntry As Variant
     UserEntry = InputBox("Enter the value")
    If UserEntry <> "" Then Range("A1").Value = UserEntry
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub GetData()
    Dim NextRow As Long
    Dim Entry1 As String, Entry2 As String
  Do
    'Determine next empty row
    NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
   '   Prompt for the data
    Entry1 = InputBox("Enter the name")
    If Entry1 = "" Then Exit Sub
    Entry2 = InputBox("Enter the amount")
    If Entry2 = "" Then Exit Sub
    '   Write the data
    Cells(NextRow, 1) = Entry1
    Cells(NextRow, 2) = Entry2
  Loop
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub GetUserRange()
    Dim UserRange As Range
    Prompt = "Select a range for the random numbers."
    Title = "Select a range"
'   Display the Input Box
    On Error Resume Next
    Set UserRange = Application.InputBox( _
        Prompt:=Prompt, _
        Title:=Title, _
        Default:=ActiveCell.Address, _
        Type:=8) 'Range selection
    On Error GoTo 0
'   Was the Input Box canceled?
    If UserRange Is Nothing Then
        MsgBox "Canceled."
    Else
        UserRange.Formula = "=RAND()"
    End If
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''Go To Statement
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub CheckUser()
    UserName = InputBox("Enter Your Name: ")
    If UserName <> "Steve Ballmer" Then GoTo WrongName
    MsgBox ("Welcome Steve...")
'   ...[More code here] ...
    Exit Sub
WrongName:
    MsgBox "Sorry. Only Steve Ballmer can run this."
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub GoToDemo()
    UserName = InputBox("Enter Your Name:")
    If UserName <> "Howard" Then GoTo WrongName
    MsgBox ("Welcome Howard...")
' -[More code here]
   Exit Sub
WrongName:
   MsgBox "Sorry. Only Howard can run this macro."
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub BadLoop()
    Dim StartVal As Integer
    Dim NumToFill As Integer
    Dim cnt As Integer
    StartVal = 1
    NumToFill = 100
    ActiveCell.Value = StartVal
    cnt = 1
DoAnother:
    ActiveCell.Offset(cnt, 0).Value = StartVal + cnt
    cnt = cnt + 1
    If cnt < NumToFill Then GoTo DoAnother Else Exit Sub
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''With…End With Statement
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub ChangeFont1()
    Selection.Font.Name = "Cambria"
    Selection.Font.Bold = True
    Selection.Font.Italic = True
    Selection.Font.Size = 12
    Selection.Font.Underline = xlUnderlineStyleSingle
    Selection.Font.ThemeColor = xlThemeColorAccent1
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub ChangeFont2()
    With Selection.Font
        .Name = "Cambria"
        .Bold = True
        .Italic = True
        .Size = 12
        .Underline = xlUnderlineStyleSingle
        .ThemeColor = xlThemeColorAccent1
    End With
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''If…Then Statement
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub Discount1()
    Dim Quantity As Variant
    Dim Discount As Double
    Quantity = InputBox("Enter Quantity: ")
    If Quantity = "" Then Exit Sub
    If Quantity >= 0 Then Discount = 0.1
    If Quantity >= 25 Then Discount = 0.15
    If Quantity >= 50 Then Discount = 0.2
    If Quantity >= 75 Then Discount = 0.25
    MsgBox "Discount: " & Discount
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub Discount2()
    Dim Quantity As Variant
    Dim Discount As Double
    Quantity = InputBox("Enter Quantity: ")
    If Quantity = "" Then Exit Sub
    If Quantity >= 0 And Quantity < 25 Then
        Discount = 0.1
    ElseIf Quantity < 50 Then
        Discount = 0.15
    ElseIf Quantity < 75 Then
        Discount = 0.2
    Else
        Discount = 0.25
    End If
    MsgBox "Discount: " & Discount
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''Select-Case Statement
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub GreetMe()
    Dim Msg As String
    Select Case Time
        Case Is < 0.5
            Msg = "Good Morning"
        Case 0.5 To 0.75
            Msg = "Good Afternoon"
        Case Else
            Msg = "Good Evening"
    End Select
    MsgBox Msg
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub Discount3()
    Dim Quantity As Variant
    Dim Discount As Double
    Quantity = InputBox("Enter Quantity: ")
    Select Case Quantity
        Case ""
            Exit Sub
        Case 0 To 24
            Discount = 0.1
        Case 25 To 49
            Discount = 0.15
        Case 50 To 74
            Discount = 0.2
        Case Is >= 75
            Discount = 0.25
    End Select
    MsgBox "Discount: " & Discount
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub GreetUser1()
    Select Case Weekday(Now)
        Case 1, 7
            MsgBox "This is the weekend"
        Case Else
            MsgBox "This is not the weekend"
    End Select
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub SelectionType()
    Select Case TypeName(Selection)
        Case "Range"
            Select Case Selection.Count
                Case 1
                    MsgBox "One cell is selected"
                Case Else
                    MsgBox Selection.Rows.Count & " rows"
            End Select
        Case "Nothing"
            MsgBox "Nothing Is selected"
        Case Else
            MsgBox "Something other than a range"
    End Select
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub CheckCell()
   Dim Msg As String
    Select Case IsEmpty(ActiveCell)
       Case True
          Msg = "is blank."
       Case Else
          Select Case ActiveCell.HasFormula
             Case True
                Msg = "has a formula"
             Case Else
                Select Case IsNumeric(ActiveCell)
                   Case True
                      Msg = "has a number"
                    Case Else
                      Msg = "has text"
                 End Select
          End Select
    End Select
   MsgBox "Cell " & ActiveCell.Address & " " & Msg
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''Do Loop
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub DoWhileDemo()
    Do While ActiveCell.Value <> Empty
        ActiveCell.Value = ActiveCell.Value * 2
        ActiveCell.Offset(1, 0).Select
    Loop
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub EnterDates1()
'   Do While, with test at the beginning
    Dim TheDate As Date
    TheDate = DateSerial(Year(Date), Month(Date), 1)
    Do While Month(TheDate) = Month(Date)
        ActiveCell = TheDate
        TheDate = TheDate + 1
        ActiveCell.Offset(1, 0).Activate
    Loop
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub EnterDates2()
'   Do While, with test at the end
    Dim TheDate As Date
    TheDate = DateSerial(Year(Date), Month(Date), 1)
    Do
        ActiveCell = TheDate
        TheDate = TheDate + 1
        ActiveCell.Offset(1, 0).Activate
    Loop While Month(TheDate) = Month(Date)
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub EnterDates3()
'   Do Until, with test at beginning
    Dim TheDate As Date
    TheDate = DateSerial(Year(Date), Month(Date), 1)
    Do Until Month(TheDate) <> Month(Date)
        ActiveCell = TheDate
        TheDate = TheDate + 1
        ActiveCell.Offset(1, 0).Activate
    Loop
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''While Wend Loop
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub EnterDates5()
    Dim TheDate As Date
    TheDate = DateSerial(Year(Date), Month(Date), 1)
    While Month(TheDate) = Month(Date)
        ActiveCell = TheDate
        TheDate = TheDate + 1
        ActiveCell.Offset(1, 0).Activate
    Wend
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''FOR Loop
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub AddOddNumbers()
    Dim Total As Double
    Dim cnt As Integer
    Total = 0
    For cnt = 1 To 1000 Step 2
        Total = Total + cnt
    Next cnt
    MsgBox Total
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub ShadeEveryThirdRow()
    Dim i As Long
    For i = 1 To 100 Step 3
        Rows(i).Interior.Color = RGB(200, 200, 200)
    Next i
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub DeleteEmptyRows()
    Dim LastRow As Long
    Dim r As Long
    Dim Counter As Long
    Application.ScreenUpdating = False
    LastRow = ActiveSheet.UsedRange.Rows.Count + _
      ActiveSheet.UsedRange.Rows(1).Row - 1
    For r = LastRow To 1 Step -1
        If Application.WorksheetFunction.CountA(Rows(r)) = 0 Then
            Rows(r).Delete
            Counter = Counter + 1
        End If
    Next r
    Application.ScreenUpdating = True
    MsgBox Counter & " empty rows were deleted."
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub SumSquareRoots()
    Dim Sum As Double
    Dim Count As Integer
    Sum = 0
    For Count = 1 To 100
        Sum = Sum + Sqr(Count)
    Next Count
    MsgBox Sum
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub DeleteRows()
    Dim RowNum As Long
    For RowNum = 10 To 2 Step -2
        Rows(RowNum).Delete
    Next RowNum
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub GoodLoop()
    Dim StartVal As Integer
    Dim NumToFill As Integer
    Dim cnt As Integer
    StartVal = 1
    NumToFill = 100
    For cnt = 0 To NumToFill - 1
      ActiveCell.Offset(cnt, 0).Value = StartVal + cnt
    Next cnt
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''Nested FOR Loop
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub RangeToVariant2()
    Dim x As Variant
    Dim r As Long, c As Integer
'   Read the data into the variant
    x = Range("data").Value
'   Loop through the variant array
    For r = 1 To UBound(x, 1)
        For c = 1 To UBound(x, 2)
'           Multiply by 2
            x(r, c) = x(r, c) * 2
        Next c
    Next r
'   Transfer the variant back to the sheet
    Range("data") = x
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub FillRange()
    Dim Col As Long
    Dim Row As Long
    For Col = 1 To 5
        For Row = 1 To 12
            Cells(Row, Col) = Rnd
        Next Row
    Next Col
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub NestedLoops()
    Dim MyArray(10, 10, 10)
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    For i = 1 To 10
        For j = 1 To 10
            For k = 1 To 10
                MyArray(i, j, k) = 100
            Next k
        Next j
    Next i
    ' Other statements go here
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub MakeCheckerboard()
    Dim Row As Integer, Col As Integer
    For Row = 1 To 8
        If WorksheetFunction.IsOdd(Row) Then
            For Col = 2 To 8 Step 2
                Cells(Row, Col).Interior.Color = 255
            Next Col
        Else
            For Col = 1 To 8 Step 2
                Cells(Row, Col).Interior.Color = 255
            Next Col
        End If
    Next Row
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub BubbleSort(List() As String)
'   Sorts the List array in ascending order
    Dim First As Long, Last As Long
    Dim i As Long, j As Long
    Dim Temp As String
    First = LBound(List)
    Last = UBound(List)
    For i = First To Last - 1
        For j = i + 1 To Last
            If List(i) > List(j) Then
                Temp = List(j)
                List(j) = List(i)
                List(i) = Temp
            End If
        Next j
    Next i
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''FOR Loop Through Collections
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub DeleteEmptySheets()
    Dim WkSht As Worksheet
    Application.DisplayAlerts = False
    For Each WkSht In ActiveWorkbook.Worksheets
        If WorksheetFunction.CountA(WkSht.Cells) = 0 Then
            WkSht.Delete
        End If
    Next WkSht
    Application.DisplayAlerts = True
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub HideSheets()
    Dim Sht As Worksheet
    For Each Sht In ActiveWorkbook.Worksheets
        If Sht.Name <> ActiveSheet.Name Then
            Sht.Visible = xlSheetHidden
        End If
    Next Sht
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub UnhideSheets()
    Dim Sht As Worksheet
    For Each Sht In ActiveWorkbook.Worksheets
        Sht.Visible = xlSheetVisible
    Next Sht
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub CountBold()
    Dim WBook As Workbook
    Dim WSheet As Worksheet
    Dim Cell As Range
    Dim cnt As Long
    For Each WBook In Workbooks
        For Each WSheet In WBook.Worksheets
            For Each Cell In WSheet.UsedRange
               If Cell.Font.Bold = True Then cnt = cnt + 1
            Next Cell
        Next WSheet
    Next WBook
    MsgBox cnt & " bold cells found"
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


' Excelpro.ir
' Hamed Ghadimi
' VBA Practice Codes