รหัส VBA ที่น่าสนใจจาก www.MindSpring.com

Selecting

Sub SelectDown()
    Range(ActiveCell, ActiveCell.End(xlDown)).Select
End Sub

Sub Select_from_ActiveCell_to_Last_Cell_in_Column()
    Dim topCel As Range
    Dim bottomCel As Range
    On Error GoTo errorHandler
    Set topCel = ActiveCell
    Set bottomCel = Cells((65536), topCel.Column).End(xlUp)
       If bottomCel.Row >= topCel.Row Then
           Range(topCel, bottomCel).Select
       End If
    Exit Sub
    errorHandler:
    MsgBox "Error no. " & Err & " - " & Error
End Sub

Sub SelectUp()
    Range(ActiveCell, ActiveCell.End(xlUp)).Select
End Sub

Sub SelectToRight()
    Range(ActiveCell, ActiveCell.End(xlToRight)).Select
End Sub

Sub SelectToLeft()
    Range(ActiveCell, ActiveCell.End(xlToLeft)).Select
End Sub

Sub SelectCurrentRegion()
    ActiveCell.CurrentRegion.Select
End Sub

Sub SelectActiveArea()
    Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).Select
End Sub

Sub SelectActiveColumn()
    If IsEmpty(ActiveCell) Then Exit Sub
    On Error Resume Next
    If IsEmpty(ActiveCell.Offset(-1, 0)) Then Set TopCell = _
       ActiveCell Else Set TopCell = ActiveCell.End(xlUp)
    If IsEmpty(ActiveCell.Offset(1, 0)) Then Set BottomCell = _
       ActiveCell Else Set BottomCell = ActiveCell.End(xlDown)
    Range(TopCell, BottomCell).Select
End Sub

Sub SelectActiveRow()
    If IsEmpty(ActiveCell) Then Exit Sub
    On Error Resume Next
    If IsEmpty(ActiveCell.Offset(0, -1)) Then Set LeftCell = _
       ActiveCell Else Set LeftCell = ActiveCell.End(xlToLeft)
    If IsEmpty(ActiveCell.Offset(0, 1)) Then Set RightCell = _
       ActiveCell Else Set RightCell = ActiveCell.End(xlToRight)
    Range(LeftCell, RightCell).Select
End Sub

Sub SelectEntireColumn()
    Selection.EntireColumn.Select
End Sub

Sub SelectEntireRow()
    Selection.EntireRow.Select
End Sub

Sub SelectEntireSheet()
    Cells.Select
End Sub

Sub ActivateNextBlankDown()
    ActiveCell.Offset(1, 0).Select
    Do While Not IsEmpty(ActiveCell)
        ActiveCell.Offset(1, 0).Select
    Loop
End Sub

Sub ActivateNextBlankToRight()
    ActiveCell.Offset(0, 1).Select
    Do While Not IsEmpty(ActiveCell)
        ActiveCell.Offset(0, 1).Select
    Loop
End Sub

Sub SelectFirstToLastInRow()
    Set LeftCell = Cells(ActiveCell.Row, 1)
    Set RightCell = Cells(ActiveCell.Row, 256)
    If IsEmpty(LeftCell) Then _
        Set LeftCell = LeftCell.End(xlToRight)
    If IsEmpty(RightCell) Then _
        Set RightCell = RightCell.End(xlToLeft)
    If LeftCell.Column = 256 And RightCell.Column = 1 Then _
        ActiveCell.Select Else Range(LeftCell, RightCell).Select
End Sub

Sub SelectFirstToLastInColumn()
    Set TopCell = Cells(1, ActiveCell.Column)
    Set BottomCell = Cells(16384, ActiveCell.Column)
    If IsEmpty(TopCell) Then Set TopCell = TopCell.End(xlDown)
    If IsEmpty(BottomCell) Then _
         Set BottomCell = BottomCell.End(xlUp)
    If TopCell.Row = 16384 And BottomCell.Row = 1 Then _
         ActiveCell.Select Else Range(TopCell, BottomCell).Select
End Sub

Sub SelCurRegCopy()
    Selection.CurrentRegion.Select
    Selection.Copy
    Range("A17").Select ' Substitute your range here
    ActiveSheet.Paste
    Application.CutCopyMode = False
End Sub

Check Values

Sub ResetValuesToZero2()
    For Each n In Worksheets("Sheet1").Range("WorkArea1")    
        If n.Value <> 0 Then
            n.Value = 0
        End If
    Next n
End Sub

Sub ResetTest1()
    For Each n In Range("B1:G13")
        If n.Value <> 0 Then
            n.Value = 0
        End If
    Next n
End Sub

Sub ResetTest2()
    For Each n In Range("A16:G28")
        If IsNumeric(n) Then
            n.Value = 0
        End If
    Next n
End Sub

Sub ResetTest3()
    For Each amount In Range("I1:I13") 
        If amount.Value <> 0 Then
            amount.Value = 0
        End If
    Next amount
End Sub

Sub ResetTest4()
    For Each n In ActiveSheet.UsedRange
        If n.Value <> 0 Then
            n.Value = 0
        End If
    Next n
End Sub

Sub ResetValues()
    On Error GoTo ErrorHandler
    For Each n In ActiveSheet.UsedRange
        If n.Value <> 0 Then
            n.Value = 0
        End If
TypeMismatch:
    Next n
ErrorHandler:
    If Err = 13 Then        'Type Mismatch
        Resume TypeMismatch
    End If
End Sub

Sub ResetValues2()
    For i = 1 To Worksheets.Count
    On Error GoTo ErrorHandler
        For Each n In Worksheets(i).UsedRange
            If IsNumeric(n) Then
                If n.Value <> 0 Then
                     n.Value = 0
ProtectedCell:
                End If
            End If
        Next n
ErrorHandler:
        If Err = 1005 Then
             Resume ProtectedCell
        End If
    Next i
End Sub

On Entry

Sub Auto_Open()
   ActiveSheet.OnEntry = "Action"
End Sub
Sub Action()
   If IsNumeric(ActiveCell) Then
     ActiveCell.Font.Bold = ActiveCell.Value >= 500
   End If
End Sub
Sub Auto_Close()
   ActiveSheet.OnEntry = ""
End Sub

Looping

'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

Test Values

' Tests the value in each cell of a column and if it is greater
' than a given number, places it in another column.  This is just
' an example so the source range, target range and test value may
' be adjusted to fit different requirements.
Sub Test_Values()
Dim topCel As Range, bottomCel As Range, _
    sourceRange As Range, targetRange As Range
Dim x As Integer, i As Integer, numofRows As Integer
Set topCel = Range("A2")
Set bottomCel = Range("A65536").End(xlUp)
If topCel.Row > bottomCel.Row Then End     
' test if source range is empty
Set sourceRange = Range(topCel, bottomCel)
Set targetRange = Range("D2")
numofRows = sourceRange.Rows.Count
x = 1
For i = 1 To numofRows
    If Application.IsNumber(sourceRange(i)) Then
        If sourceRange(i) > 1300000 Then
            targetRange(x) = sourceRange(i)
            x = x + 1
        End If
    End If
Next
End Sub