Developers Depot

Sub Main()

Sort Range(”A2:C5″), “C”, xlAscending

End Sub

Sub Sort(DataRangeWithoutHeader As Range, ColumnLetterToSort As String, SortOrder As XlSortOrder)

Dim OriginalSelectedRange As Range
Dim keyRange As Range
Dim Column As Variant
Dim ColumnVisibility As New Collection

‘Remeber what was selected
Set OriginalSelectedRange = Selection

‘prevent user from watching the screen update
Application.ScreenUpdating = False

‘unhide any hidden cols and add to Collection Variable
For Each Column In DataRangeWithoutHeader.Columns
If Column.EntireColumn.Hidden = True Then
Column.EntireColumn.Hidden = False
ColumnVisibility.Add Column
End If
Next Column

‘clear
ActiveSheet.Sort.SortFields.Clear

’sort
Set keyRange = Range(ColumnLetterToSort & DataRangeWithoutHeader.Row & “:” & ColumnLetterToSort & DataRangeWithoutHeader.End(xlDown).Row)
ActiveSheet.Sort.SortFields.Add key:=keyRange, SortOn:=xlSortOnValues, order:=SortOrder, DataOption:=xlSortNormal
With ActiveSheet.Sort
.SetRange DataRangeWithoutHeader
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

‘put back any hidden columns
Do While ColumnVisibility.Count > 0
Set Column = ColumnVisibility.Item(1)
Column.EntireColumn.Hidden = True
ColumnVisibility.Remove (1)
Loop

‘Select the original range
OriginalSelectedRange.Select

‘Restore Default
Application.ScreenUpdating = True

End Sub

Public Declare Function GetTickCount Lib “kernel32″ () As Long
Public timeStart As Long
Public timeEnd As Long

Sub Main()

     timeStart = GetTickCount
     ‘do something
     timeEnd = GetTickCount
     MsgBox timeEnd - timeStart & ” milliseconds”

End Sub

Sub Main()
       FormatRows “SubTotal”, Range(”A1:A200″), “A”, “G”

End Sub

Sub FormatRows(FindWhat As String, SearchRange As Range, formatColStart As String, formatColEnd As String)
    Dim OriginalSelectedRange As Range
    Dim firstFoundCell As Range
    Dim curFoundCell As Range
    Dim foundCell As Variant

On Error GoTo FormatRows_Error

    ‘Remeber what was selected
    Set OriginalSelectedRange = Selection
    ‘prevent user from watching the screen update
    Application.ScreenUpdating = False

    ’select range to search
    SearchRange.Select
       With Selection
        ‘try to find value
        Set foundCell = .Find(FindWhat, LookIn:=xlValues)
        ‘if a value was found in that selected range
        If Not foundCell Is Nothing Then
            ‘remember first found cell
            Set firstFoundCell = Range(foundCell.Address)
                Do
                ‘format
                Range((formatColStart & foundCell.Row) & “:” & (formatColEnd & foundCell.Row)).Font.Bold = True
                Range((formatColStart & foundCell.Row) & “:” & (formatColEnd & foundCell.Row)).Interior.ColorIndex = 3
                ‘try to find again
                Set foundCell = .FindNext(foundCell)
                ‘if a value was found in selected range AND its not the first found Cell
                If Not foundCell Is Nothing And foundCell.Address <> firstFoundCell.Address Then
                    Set curFoundCell = Range(foundCell.Address)
                Else
                     Exit Do
                End If
              Loop
      End If
      End With
    ‘Select the original range
    OriginalSelectedRange.Select
    ‘Restore Default
    Application.ScreenUpdating = True

On Error GoTo 0
   Exit Sub

FormatRows_Error:
    ‘Restore Default
    Application.ScreenUpdating = True
    MsgBox “Error ” & Err.Number & ” (” & Err.Description & “) in procedure FormatRows”
End Sub

Sub OutsideBorders(rng As range)

    With rng
        ‘Style
        .Borders.LineStyle = xlSolid
        ‘None
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlInsideVertical).LineStyle = xlNone
        .Borders(xlInsideHorizontal).LineStyle = xlNone
        ‘Edge
        .Borders(xlEdgeLeft).LineStyle = xlSolid
        .Borders(xlEdgeTop).LineStyle = xlSolid
        .Borders(xlEdgeBottom).LineStyle = xlSolid
        .Borders(xlEdgeRight).LineStyle = xlSolid
    End With

End Sub

Sub Main()
       Dim ColumnNumber As Integer
       ColumnNumber = 1
       ‘Range(”A1″)=”Hello World”
    range(ColumnLetter(ColumnNumber) & 1) = “Hello World”
   End Sub

Function ColumnLetter(ColumnNumber As Integer) As String
   If ColumnNumber > 26 Then

    ‘ 1st character:  Subtract 1 to map the characters to 0-25,
    ‘                 but you don’t have to remap back to 1-26
    ‘                 after the ‘Int’ operation since columns
    ‘                 1-26 have no prefix letter

    ‘ 2nd character:  Subtract 1 to map the characters to 0-25,
    ‘                 but then must remap back to 1-26 after
    ‘                 the ‘Mod’ operation by adding 1 back in
    ‘                 (included in the ‘65′)

    ColumnLetter = Chr(Int((ColumnNumber - 1) / 26) + 64) & _
                   Chr(((ColumnNumber - 1) Mod 26) + 65)
  Else
    ‘ Columns A-Z
    ColumnLetter = Chr(ColumnNumber + 64)
  End If
 End Function

Sub main()

    RemoveSubtotals range(”1:900″)

End Sub

Sub RemoveSubtotals(rng As range)

On Errror GoTo oops
    With rng
        .Font.Bold = False
        .RemoveSubtotal
    End With
oops:
    On Error GoTo 0

End Sub

Sub main()

    AllBorders range(”g17:h17″)

End Sub

Sub AllBorders(rng As range)

    With rng
        ’style
        .Borders.LineStyle = xlSolid
        ‘none
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        ‘inside
        .Borders(xlInsideVertical).LineStyle = xlSolid
        .Borders(xlInsideHorizontal).LineStyle = xlSolid
        ‘edge
        .Borders(xlEdgeLeft).LineStyle = xlSolid
        .Borders(xlEdgeTop).LineStyle = xlSolid
        .Borders(xlEdgeBottom).LineStyle = xlSolid
        .Borders(xlEdgeRight).LineStyle = xlSolid
    End With

End Sub

Sub Main()
    Dim bolSheetExists As Boolean
    bolSheetExists = WorkSheetExists(”Sheet1″)
End Sub

Function WorkSheetExists(xlWkshtName As String) As Boolean
       Dim xlWksht As Worksheet
       WorkSheetExists = False
   On Error Resume Next
        Set xlWksht = Worksheets(xlWkshtName)
   On Error GoTo 0
       If Not xlWksht Is Nothing Then
         WorkSheetExists = True
    End If
   End Function

Have you ever wondered why it takes so long for your workbook to execute the vba code.  That’s because of the default settings in Excel.  Here’s how you can speed it up.

Sub main()

ApplicationSettings False

‘do some processing for example loading and manipulating workbook

ApplicationSettings True

End Sub

Sub ApplicationSettings(Enabled As Boolean)

‘Status Bar
Application.DisplayStatusBar = Enabled

‘Message boxes from appearing
Application.DisplayAlerts = Enabled

‘Event driven procedures
Application.EnableEvents = Enabled

‘Calculations
If Enabled = False Then
Application.Calculation = xlCalculationManual
Else
Application.Calculation = xlCalculationAutomatic
End If

‘PageBreaks
ActiveSheet.DisplayPageBreaks = Enabled

‘Seeing Excel Changes
Application.ScreenUpdating = Enabled

End Sub