VBA Excel

These examples were obtained from this URL:  http://www.mindspring.com/~tflynn/excelvba4.html

'-----You might want to step through this using the "Watch" feature-----

Sub Accumulate()
Dim n As Integer
Dim t As Integer
    For n = 1 To 10
        t = t + n
    Next n
    MsgBox "        The total is " & t
End Sub


'-----This sub checks values in a range 10 rows by 5 columns
'moving left to right, top to bottom-----

Sub CheckValues1()
Dim rwIndex As Integer
Dim colIndex As Integer
    For rwIndex = 1 To 10
            For colIndex = 1 To 5
                If Cells(rwIndex, colIndex).Value <> 0 Then _
                    Cells(rwIndex, colIndex).Value = 0
            Next colIndex
    Next rwIndex
End Sub


'-----Same as above using the "With" statement instead of "If"-----

Sub CheckValues2()
Dim rwIndex As Integer
Dim colIndex As Integer
    For rwIndex = 1 To 10
         For colIndex = 1 To 5
             With Cells(rwIndex, colIndex)
                 If Not (.Value = 0) Then Cells(rwIndex, colIndex).Value = 0
             End With
         Next colIndex
    Next rwIndex
End Sub


'-----Same as CheckValues1 except moving top to bottom, left to right-----

Sub CheckValues3()
Dim colIndex As Integer
Dim rwIndex As Integer
    For colIndex = 1 To 5
            For rwIndex = 1 To 10
                If Cells(rwIndex, colIndex).Value <> 0 Then _
                    Cells(rwIndex, colIndex).Value = 0
            Next rwIndex
    Next colIndex
End Sub


'-----Enters a value in 10 cells in a column and then sums the values------

Sub EnterInfo()
Dim i As Integer
Dim cel As Range
Set cel = ActiveCell
    For i = 1 To 10
        cel(i).Value = 100
    Next i
cel(i).Value = "=SUM(R[-10]C:R[-1]C)"
End Sub


' Loop through all worksheets in workbook and reset values
' in a specific range on each sheet.

Sub Reset_Values_All_WSheets()
Dim wSht As Worksheet
Dim myRng As Range
Dim allwShts As Sheets
Dim cel As Range
Set allwShts = Worksheets

For Each wSht In allwShts
Set myRng = wSht.Range("A1:A5, B6:B10, C1:C5, D4:D10")
    For Each cel In myRng
        If Not cel.HasFormula And cel.Value <> 0 Then
            cel.Value = 0
        End If
    Next cel
Next wSht

End Sub


Back

' The distinction between Hide(False) and xlVeryHidden:
' Visible = xlVeryHidden - Sheet/Unhide is grayed out. To unhide sheet, you must set
' the Visible property to True.
' Visible = Hide(or False) - Sheet/Unhide is not grayed out

' To hide specific worksheet
Sub Hide_WS1()
    Worksheets(2).Visible = Hide  ' you can use Hide or False
End Sub


' To make a specific worksheet very hidden
Sub Hide_WS2()
    Worksheets(2).Visible = xlVeryHidden
End Sub


' To unhide a specific worksheet
Sub UnHide_WS()
    Worksheets(2).Visible = True
End Sub


' To toggle between hidden and visible
Sub Toggle_Hidden_Visible()
    Worksheets(2).Visible = Not Worksheets(2).Visible
End Sub


' To set the visible property to True on ALL sheets in workbook
Sub Un_Hide_All()
Dim sh As Worksheet
For Each sh In Worksheets
    sh.Visible = True
Next
End Sub


' To set the visible property to xlVeryHidden on ALL sheets in workbook.
' Note: The last "hide" will fail because you can not hide every sheet
' in a work book.
Sub xlVeryHidden_All_Sheets()
On Error Resume Next
Dim sh As Worksheet
For Each sh In Worksheets
    sh.Visible = xlVeryHidden
Next
End Sub


Back

'///....To find and select a range of dates based on the month and year only....\\\


Sub FindDates()
On Error GoTo errorHandler
Dim startDate As String
Dim stopDate As String
Dim startRow As Integer
Dim stopRow As Integer
    startDate = InputBox("Enter the Start Date:  (mm/dd/yy)")
        If startDate = "" Then End
    stopDate = InputBox("Enter the Stop Date:  (mm/dd/yy)")
        If stopDate = "" Then End
    startDate = Format(startDate, "mm/??/yy")
    stopDate = Format(stopDate, "mm/??/yy")
    startRow = Worksheets("Table").Columns("A").Find(startDate, _
        lookin:=xlValues, lookat:=xlWhole).Row
    stopRow = Worksheets("Table").Columns("A").Find(stopDate, _
        lookin:=xlValues, lookat:=xlWhole).Row
    Worksheets("Table").Range("A" & startRow & ":A" & stopRow).Copy _
        destination:=Worksheets("Report").Range("A1")
End
errorHandler:
MsgBox "There has been an error:  " & Error() & Chr(13) _
    & "Ending Sub.......Please try again", 48
End Sub

Back

Sub MyTestArray()
Dim myCrit(1 To 4) As String ' Declaring array and setting bounds
Dim Response As String
Dim i As Integer
Dim myFlag As Boolean
myFlag = False

'  To fill array with values
    myCrit(1) = "A"
    myCrit(2) = "B"
    myCrit(3) = "C"
    myCrit(4) = "D"

Do Until myFlag = True
Response = InputBox("Please enter your choice: (i.e. A,B,C or D)")
'  Check if Response matches anything in array
    For i = 1 To 4  'UCase ensures that Response and myCrit are the same case
        If UCase(Response) = UCase(myCrit(i)) Then
            myFlag = True: Exit For
        End If
    Next i
Loop
End Sub

Back

'// This sub will replace information in all sheets of the workbook \\
'//...... Replace "old stuff" and "new stuff" with your info ......\\

Sub ChgInfo()
Dim Sht As Worksheet
For Each Sht In Worksheets
    Sht.Cells.Replace What:="old stuff", _ 
        Replacement:="new stuff", LookAt:=xlPart, MatchCase:=False
Next
End Sub

Back

' This sub will move the sign from the right-hand side thus changing a text string into a value.

Sub MoveMinus() 
On Error Resume Next 
Dim cel As Range 
Dim myVar As Range 
Set myVar = Selection

For Each cel In myVar 
    If Right((Trim(cel)), 1) = "-" Then 
        cel.Value = cel.Value * 1 
    End If 
Next
 
   With myVar 
    .NumberFormat = "#,##0.00_);[Red](#,##0.00)" 
    .Columns.AutoFit 
End With 

End Sub 

Back

' This sub calls the DetermineUsedRange sub and passes
' the empty argument "usedRng".

Sub CallDetermineUsedRange()
On Error Resume Next
Dim usedRng As Range
DetermineUsedRange usedRng

    MsgBox usedRng.Address

End Sub

' This sub receives the empty argument "usedRng" and determines
' the populated cells of the active worksheet, which is stored
' in the variable "theRng", and passed back to the calling sub.

Sub DetermineUsedRange(ByRef theRng As Range)
Dim FirstRow As Integer, FirstCol As Integer, _
    LastRow As Integer, LastCol As Integer
On Error GoTo handleError

FirstRow = Cells.Find(What:="*", _
      SearchDirection:=xlNext, _
      SearchOrder:=xlByRows).Row
FirstCol = Cells.Find(What:="*", _
      SearchDirection:=xlNext, _
      SearchOrder:=xlByColumns).Column

LastRow = Cells.Find(What:="*", _
      SearchDirection:=xlPrevious, _
      SearchOrder:=xlByRows).Row
LastCol = Cells.Find(What:="*", _
      SearchDirection:=xlPrevious, _
      SearchOrder:=xlByColumns).Column

Set theRng = Range(Cells(FirstRow, FirstCol), _
    Cells(LastRow, LastCol))

handleError:
End Sub

Back

'Copies only the weekdates from a range of dates.

Sub EnterDates()
Columns(3).Clear
Dim startDate As String, stopDate As String, startCel As Integer, stopCel As Integer, dateRange As Range
On Error Resume Next

Do
    startDate = InputBox("Please enter Start Date:  Format(mm/dd/yy)", "START DATE")
    If startDate = "" Then End
Loop Until startDate = Format(startDate, "mm/dd/yy") _
    Or startDate = Format(startDate, "m/d/yy")

Do
    stopDate = InputBox("Please enter Stop Date:  Format(mm/dd/yy)", "STOP DATE")
    If stopDate = "" Then End
Loop Until stopDate = Format(stopDate, "mm/dd/yy") _
    Or stopDate = Format(stopDate, "m/d/yy")

startDate = Format(startDate, "mm/dd/yy")
stopDate = Format(stopDate, "mm/dd/yy")

startCel = Sheets(1).Columns(1).Find(startDate, LookIn:=xlValues, lookat:=xlWhole).Row
stopCel = Sheets(1).Columns(1).Find(stopDate, LookIn:=xlValues, lookat:=xlWhole).Row

On Error GoTo errorHandler

Set dateRange = Range(Cells(startCel, 1), Cells(stopCel, 1))

Call CopyWeekDates(dateRange)  ' Passes the argument dateRange to the CopyWeekDates sub.

Exit Sub
errorHandler:
    If startCel = 0 Then MsgBox "Start Date is not in table.", 64
    If stopCel = 0 Then MsgBox "Stop Date is not in table.", 64
End Sub

Sub CopyWeekDates(myRange)
Dim myDay As Variant, cnt As Integer
cnt = 1
For Each myDay In myRange
    If WeekDay(myDay, vbMonday) < 6 Then
        With Range("C1")(cnt)
            .NumberFormat = "mm/dd/yy"
            .Value = myDay
        End With
    cnt = cnt + 1
    End If
Next
End Sub

Back