更新时间:2022-08-20 14:18:57
ThisWorkbook.Worksheets("Sheet1").Activate
Worksheets.Add(Before,After,Count,Type)
工作表对象.Copy(Before,After)
ActiveSheet.Copy After:=Worksheets(Worksheets.Count)
工作表对象.Move(Before,After)
Worksheets("Sheet1").Move After:=Worksheets("Sheet3")
Worksheets("Sheet1").Name = "示例"
Sub ReNameSheet() Dim xStr As String Retry: Err.Clear xStr = InputBox("请输入工作表的新名称:" _ , "重命名工作表", ActiveSheet.Name) If xStr = "" Then Exit Sub On Error Resume Next ActiveSheet.Name = xStr If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description Err.Clear GoTo Retry End If On Error GoTo 0 '......... End Sub
工作表对象.CodeName
Worksheets("Sheet1").Activate
Sheet1CodeName.Activate
工作表对象.Delete
Worksheets("示例").Delete
Worksheets(1).Select (False) Worksheets(2).Select (False)
工作表对象.Select(Replace)
Sub PreviousSheet() If ActiveSheet.Index <> 1 Then MsgBox "选取当前工作簿中当前工作表的前一个工作表" ActiveSheet.Previous.Activate Else MsgBox "已到第一个工作表" End If End Sub
Sub NextSheet() If ActiveSheet.Index <> Worksheets.Count Then MsgBox "选取当前工作簿中当前工作表的下一个工作表" ActiveSheet.Next.Activate Else MsgBox "已到最后一个工作表" End If End Sub
Sub WorksheetNum() Dim i As Long i = Worksheets.Count MsgBox "当前工作簿的工作表数为:" & Chr(10) & i End Sub Sub WorksheetNum() Dim i As Long i = Sheets.Count MsgBox "当前工作簿的工作表数为:" & Chr(10) & i End Sub
工作表对象.SaveAs(FileName, FileFormat, Password, WriteResPassword, ReadOnlyRecommended, CreateBackup, AddToMru, TextCodepage, TextVisualLayout, Local)
Worksheets("Sheet1").Visible = False
Set NewSheet = Worksheets.Add NewSheet.Visible = xlVeryHidden NewSheet.Range("A1:D4").Formula = "=RAND()"
Sub UnhideAllWorksheets() Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets ws.Visible = xlSheetVisible Next ws Set ws = Nothing End Sub
工作表对象.Protect(Password, DrawingObjects, Contents, Scenarios, UserInterfaceOnly, AllowFormattingCells, AllowFormattingColumns, AllowFormattingRows, AllowInsertingColumns, AllowInsertingRows, AllowInsertingHyperlinks, AllowDeletingColumns, AllowDeletingRows, AllowSorting, AllowFiltering, AllowUsingPivotTables)
工作表对象.Unprotect(Password)
Sub ProtectSheet() MsgBox "保护当前工作表并设定密码" ActiveSheet.Protect Password:="fanjy" End Sub
Sub UnprotectSheet() MsgBox "撤销当前工作表保护" ActiveSheet.Unprotect End Sub
Sub ProtectAllWorkSheets() On Error Resume Next Dim ws As Worksheet Dim myPassword As String myPassword = InputBox("请输入您的密码" & vbCrLf & _ "(不输入表明无密码)" & vbCrLf & vbCrLf & _ "确保您没有忘记密码!", "输入密码") For Each ws In ThisWorkbook.Worksheets ws.Protect (myPassword) Next ws End Sub
Sub UnprotectAllWorkSheets() On Error Resume Next Dim ws As Worksheet Dim myPassword As String myPassword = InputBox("请输入您的密码" & vbCrLf & _ "(不输入表示无密码)", "输入密码") For Each ws In ThisWorkbook.Worksheets ws.Unprotect (myPassword) Next ws End Sub
Sub OnlyEditUnlockedCells() Sheets("Sheet1").EnableSelection = xlUnlockedCells ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True End Sub
工作表对象.PrintPreview(EnableChanges)
工作表对象.PrintOut(From, To, Copies, Preview, ActivePrinter, PrintToFile, Collate, PrToFileName, IgnorePrintAreas)
工作表对象.ShowDataForm
工作表对象.UsedRange
工作表对象.PasteSpecial(Format, Link, DisplayAsIcon, IconFileName, IconIndex, IconLabel, NoHTMLFormatting)
工作表对象.PasteSpecial(Format)
Worksheets("Sheet1").Range("D1").Select ActiveSheet.PasteSpecial Format:= _ "Microsoft Word 12.0 Document Object"
Worksheets(1).Calculate
Worksheets(1).ScrollArea = "A1:C50"
Worksheets(1).ScrollArea = ""
工作表对象.SetBackgroundPicture(FileName)
Worksheets(1).SetBackgroundPicture "c:/graphics/watermark.gif"
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