Do While Worksheets.Count < 5
    ThisWorkbook.Sheets.Add
Loop

Dim wrkSheetName As String
wrkSheetName = "Sample Chart"
Sheets(Sheets.Count).Name = wrkSheetName

Worksheets(Array(1, 3, 5)).Select
Worksheets(3).Activate

Sub GroupWorksheets()
    Dim arrstrNames(1 To 3) As String
    Dim i As Integer
    arrstrNames(1) = "Sample1"
    arrstrNames(2) = "Sample2"
    arrstrNames(3) = "Sample3"
    Worksheets(arrstrNames(1)).Select
    For i = 2 To 3
        Worksheets(arrstrNames(i)).Select Replace:=False
    Next i
End Sub

Sub FormatWorksheetsGroup()
    Dim shts As Sheets
    Dim wks As Worksheet
    Set shts = Worksheets(Array(1, 3, 5))
    For Each wks In shts
        wks.Range("A1").Value = 100
        wks.Range("A1").Font.Bold = True
    Next wks
End Sub

'- - - 下面的代码运行正常 - - - -
Sub test1()
    Sheets(1).Visible = xlHidden
    Sheets(1).Activate
End Sub
'- - - 下面的代码运行错误，作用于对象的方法无效 - - - -
Sub test2()
    Sheets(1).Visible = xlHidden
    Sheets(1).Select
End Sub

'- - - 下面的代码运行正常 - - - -
Sub Test3()
    ActiveWorkbook.Sheets(Array(1, 2, 3)).Select
End Sub
'- - - 下面的代码运行错误，对象不支持该属性和方法 - - - -
Sub Test4()
    ActiveWorkbook.Sheets(Array(1, 2, 3)).Activate
End Sub

Sub ChageWksObjectName()
  Dim ws As Worksheet
  Dim sPrevCodeName As String
  Dim sNewCodeName As String
  '设置新对象的名称
  sNewCodeName = "ws_main"
  '增加新工作表
  Set ws = Worksheets.Add
  '获取新增工作表的对象名称
  sPrevCodeName = ws.CodeName
  '变化新增工作表的对象名称
  ThisWorkbook.VBProject.VBComponents(sPrevCodeName). _
                        Properties("_CodeName") = sNewCodeName
End Sub
Sub Test()
  ws_main.Range("A1").Value = "This is it!"
End Sub

Sub ActivateFirstsheetInBook()
    Sheets(1).Activate
End Sub

Sub ReferenceShtByIndexNumber()
    Sheets(1).[A1:D4].Copy Sheets(2).[A1]
End Sub

Sub ActivateSheet1_1()
    Sheets("Sheet1").Activate
End Sub

Sub ReferenceShtByGivenName()
    [Sheet1!A1:D4].Copy [Sheet2!A1]
End Sub

Sub ActivateSheet1_2()
    Sheet1.Activate
End Sub

Sub ReferenceShtByCodeName()
    Sheet1.[A1:D4].Copy Sheet2.[A1]
End Sub

Function WorksheetExists(wb As Workbook, strName As String) As Boolean
    Dim str As String
    On Error GoTo worksheetExistsErr
    str = wb.Worksheets(strName).Name
    WorksheetExists = True
    Exit Function
worksheetExistsErr:
    WorksheetExists = False
End Function

Function WorksheetCodeNameExists(wb As Workbook, sCodeName As String) As Boolean
    Dim str As String
    Dim ws As Worksheet
    WorksheetCodeNameExists = False
    For Each ws In wb.Worksheets
        If StrComp(ws.CodeName, sCodeName, vbTextCompare) = 0 Then
            WorksheetCodeNameExists = True
            Exit For
        End If
    Next
    Set ws = Nothing
End Function

Function SheetExists(SheetName As String) As Boolean
    SheetExists = False
    On Error GoTo NoSuchSheet
    If Len(Sheets(SheetName).Name) > 0 Then
        SheetExists = True
        Exit Function
  End If
NoSuchSheet:
End Function

Function DoesWksExist1(sWksName As String) As Boolean
    Dim i As Long
    For i = Worksheets.Count To 1 Step -1
        If Sheets(i).Name = sWksName Then
            Exit For
    End If
    Next
    If i = 0 Then
        DoesWksExist1 = False
    Else
        DoesWksExist1 = True
    End If
End Function

Function DoesWksExist2(sWksName As String) As Boolean
    Dim wkb As Worksheet
    On Error Resume Next
    Set wkb = Sheets(sWksName)
    On Error GoTo 0
    DoesWksExist2 = IIf(Not wkb Is Nothing, True, False)
End Function

Function SheetExists(sname) As Boolean
    '如果活动工作簿中存在该工作表则返回True
    Dim x As Object
    On Error Resume Next
    Set x = ActiveWorkbook.Sheets(sname)
    If Err = 0 Then SheetExists = True Else SheetExists = False
End Function

Function SheetExists(SName As String, Optional wb As Workbook) As Boolean
    Dim ws As Worksheet
    '默认使用活动工作表
    If wb Is Nothing Then
        Set wb = ActiveWorkbook
    End If
    On Error Resume Next
    SheetExists = CBool(Not wb.Sheets(SName) Is Nothing)
    On Error GoTo 0
End Function

Sub HideRow()
  Dim iRow As Long
    MsgBox "隐藏当前单元格所在的行"
    iRow = ActiveCell.Row
    ActiveSheet.Rows(iRow).Hidden = True
    MsgBox "取消隐藏"
    ActiveSheet.Rows(iRow).Hidden = False
End Sub

Sub HideColumn()
    Dim iColumn As Long
    MsgBox "隐藏当前单元格所在列"
    iColumn = ActiveCell.Column
    ActiveSheet.Columns(iColumn).Hidden = True
    MsgBox "取消隐藏"
    ActiveSheet.Columns(iColumn).Hidden = False
End Sub

Sub InsertRow()
    Dim rRow As Long
    MsgBox "在当前单元格上方插入一行"
    rRow = Selection.Row
    ActiveSheet.Rows(rRow).Insert
End Sub

Sub InsertColumn()
  Dim cColumn As Long
    MsgBox "在当前单元格所在行的左边插入一行"
    cColumn = Selection.Column
    ActiveSheet.Columns(cColumn).Insert
End Sub

Sub InsertManyRow()
    MsgBox "在当前单元格所在行上方插入三行"
    Dim rRow As Long, i As Long
    For i = 1 To 3
        rRow = Selection.Row
        ActiveSheet.Rows(rRow).Insert
    Next i
End Sub

Sub SetRowHeight()
    MsgBox "将当前单元格所在的行高设置为25"
    Dim rRow As Long, iRow As Long
    rRow = ActiveCell.Row
    iRow = ActiveSheet.Rows(rRow).RowHeight
    ActiveSheet.Rows(rRow).RowHeight = 25
    MsgBox "恢复到原来的行高"
    ActiveSheet.Rows(rRow).RowHeight = iRow
End Sub

Sub SetColumnWidth()
    MsgBox "将当前单元格所在列的列宽设置为20"
    Dim cColumn As Long, iColumn As Long
    cColumn = ActiveCell.Column
    iColumn = ActiveSheet.Columns(cColumn).ColumnWidth
    ActiveSheet.Columns(cColumn).ColumnWidth = 20
    MsgBox "恢复至原来的列宽"
    ActiveSheet.Columns(cColumn).ColumnWidth = iColumn
End Sub

Sub ReSetRowHeightAndColumnWidth()
    MsgBox "将当前单元格所在的行高和列宽恢复为标准值"
    Selection.UseStandardHeight = True
    Selection.UseStandardWidth = True
End Sub

Sub SetSheetTabColor()
    MsgBox "设置当前工作表标签的颜色"
    ActiveSheet.Tab.ColorIndex = 7
End Sub

Sub SetSheetTabColorDefault()
    MsgBox "将当前工作表标签颜色设置为默认值"
    ActiveSheet.Tab.ColorIndex = -4142
End Sub

Sub HideOrShowSheetTab()
    MsgBox "隐藏/显示工作表标签"
    ActiveWindow.DisplayWorkbookTabs = Not ActiveWindow.DisplayWorkbookTabs
End Sub

Sub PageCount()
    Dim i As Long
    i = (ActiveSheet.HPageBreaks.Count + 1) * (ActiveSheet.VPageBreaks.Count + 1)
    MsgBox "当前工作表共" & i & "页."
End Sub

Sub SortSheets()
    If MsgBox("想排序工作表吗?", vbOKCancel + vbQuestion, "排序工作表") = vbOK Then
        SortAllSheets
    End If
End Sub

Sub SortAllSheets()
    '排序工作表
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range, i As Integer
    Dim cSheets As Integer
    Dim sSheets() As String
 
    Set wb = ActiveWorkbook
 
    '获取数组的实际大小
    cSheets = wb.Sheets.Count
    ReDim sSheets(1 To cSheets)
 
    '使用工作表名称填充数组
    For i = 1 To cSheets
        sSheets(i) = wb.Sheets(i).Name
    Next
 
    '创建新的工作表并在其第一列放置名称
    Set ws = wb.Worksheets.Add
    For i = 1 To cSheets
        ws.Cells(i, 1).Value = sSheets(i)
    Next
 
    '排序列
    ws.Columns(1).Sort Key1:=ws.Columns(1), Order1:=xlAscending
 
    '重新填充数组
    For i = 1 To cSheets
        sSheets(i) = ws.Cells(i, 1).Value
    Next
 
    '删除临时工作表
    Application.DisplayAlerts = False
    ws.Delete
    Application.DisplayAlerts = True
 
    '通过移动每个工作表到最后来重新排列工作表
    For i = 1 To cSheets
        wb.Sheets(sSheets(i)).Move After:=wb.Sheets(cSheets)
    Next
End Sub

Sub AlphabetizeWorksheets(wb As Workbook)
    Dim bSorted As Boolean
    Dim nSheetsSorted As Integer
    Dim nSheets As Integer
    Dim n As Integer
    nSheets = wb.Worksheets.Count
    nSheetsSorted = 0
    Do While (nSheetsSorted < nSheets) And Not bSorted
        bSorted = True
        nSheetsSorted = nSheetsSorted + 1
        For n = 1 To nSheets - nSheetsSorted
            If StrComp(wb.Worksheets(n).Name, wb.Worksheets(n + 1).Name, vbTextCompare) > 0 Then
                wb.Worksheets(n + 1).Move Before:=wb.Worksheets(n)
                bSorted = False
            End If
        Next
    Loop
End Sub

Sub SortWorksheets2()
  '根据字母对工作表排序
    Dim i As Long, j As Long
    For i = 1 To Sheets.Count
        For j = 1 To Sheets.Count - 1
            If UCase$(Sheets(j).Name) > UCase$(Sheets(j + 1).Name) Then
                Sheets(j).Move After:=Sheets(j + 1)
            End If
        Next j
    Next i
End Sub

Sub SortWorksheets3()
  '以升序排列工作表
    Dim sCount As Integer, i As Integer, j As Integer
    Application.ScreenUpdating = False
    sCount = Worksheets.Count
    If sCount = 1 Then Exit Sub
    For i = 1 To sCount - 1
        For j = i + 1 To sCount
            If Worksheets(j).Name < Worksheets(i).Name Then
                Worksheets(j).Move Before:=Worksheets(i)
            End If
        Next j
    Next i
End Sub

Sub Delete_EmptySheets()
    Dim sh As Worksheet
    For Each sh In ThisWorkbook.Worksheets
        If Application.WorksheetFunction.CountA(sh.Cells) = 0 Then
            Application.DisplayAlerts = False
            sh.Delete
            Application.DisplayAlerts = True
        End If
    Next
End Sub

Sub SynchSheets()
    '选择工作簿其他工作表中与活动工作表所选单元格区域相同的区域
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    Dim UserSheet As Worksheet, sht As Worksheet
    Dim TopRow As Long, LeftCol As Integer
    Dim UserSel As String
 
    Application.ScreenUpdating = False
 
    '记住当前工作表
    Set UserSheet = ActiveSheet
 
    '保存当前工作表的信息
    TopRow = ActiveWindow.ScrollRow
    LeftCol = ActiveWindow.ScrollColumn
    UserSel = ActiveWindow.RangeSelection.Address
 
    '遍历工作表
    For Each sht In ActiveWorkbook.Worksheets
        If sht.Visible Then '跳过隐藏的工作表
            sht.Activate
            Range(UserSel).Select
            ActiveWindow.ScrollRow = TopRow
            ActiveWindow.ScrollColumn = LeftCol
        End If
    Next sht
 
    '恢复原始的位置
    UserSheet.Activate
    Application.ScreenUpdating = True
End Sub

Sub sample01()
    Worksheets("Sheet1").UsedRange.Select
End Sub

Dim cellRange As Range,RowNum As Long,ColNum As Long
Set cellRange=Worksheets("Sheet1").UsedRange '设置已用单元格区域并赋值给变量
RowNum=cellRange.Rows.Count '已用单元格区域的行数
ColNum=cellRange.Columns.Count '已用单元格区域的列数
<span style="color: #0000ff;">UsedRange属性应用示例</span>
现在，我们举几个例子，进一步说明UsedRange属性的用法。
<span style="color: #0000ff;">[示例一]</span>下面的程序在活动工作表已使用单元格区域中，当该区域不包含任何公式时，清除该区域不能打印的字符。其中，ActiveSheet.UsedRange 代表当前工作表中已使用单元格区域组成的Range对象。(By Chip Pearson)
<pre lang="vb">
Sub CleanUp()
    Dim TheCell As Range
    For Each TheCell In ActiveSheet.UsedRange
      With TheCell
          If .HasFormula = False Then
              .Value = Application.WorksheetFunction.Clean(.Value)
          End If
      End With
    Next TheCell
End Sub

Public Sub Delete_First_Character(Optional ByRef objRange As Range = Nothing)
    Dim objCell As Range
    On Error Resume Next
 
    If (objRange Is Nothing) Then
       Set objRange = Application.InputBox(Prompt:="请选择单元格区域", _
          Title:="删除第一个字符", _
          Type:=8, _
          Default:=ActiveSheet.UsedRange.Address) '设置缺省选区为已用区域
    End If
 
    Err.Clear
 
    Set objRange = objRange.SpecialCells(xlCellTypeConstants)
 
    If (Err.Number <> 0&) Or (objRange Is Nothing) Then
        MsgBox "在指定的单元格区域中没有符合要求的单元格.", _
          vbExclamation Or vbOKOnly, _
          ActiveWorkbook.Name
        Exit Sub
    End If
 
    On Error GoTo Exit_Delete_First_Character
 
    Application.ScreenUpdating = False
 
    For Each objCell In objRange
        objCell = Mid$(objCell, 2)
    Next objCell
 
Exit_Delete_First_Character:
 
    On Error Resume Next
 
    Application.ScreenUpdating = True
End Sub

Private Sub CommandButton1_Click()
    Dim r As Long
 
    For r = UsedRange.Rows.Count To 1 Step -1
        If Range("E" & r) = "finish" Then _
            Range("A:G").Rows(r).Interior.ColorIndex = 10
        Next r
 
    For r = UsedRange.Rows.Count To 1 Step -1
        If Range("E" & r) = "" Then _
            Range("A:G").Rows(r).Interior.ColorIndex = 2
    Next r
End Sub

Sub Find_AND()
    Dim rng As Range
    Dim what As String