Excel Application操作指南

Application.Workbooks(1).Worksheets(1).Cells(1,1)=20

Set xl=CreateObject("Excel.Sheet") xl.Application.Workbooks.Open "newbook.xls"

Sub ListAddIns() Dim myAddin As AddIn For Each myAddin In AddIns MsgBox myAddin.FullName Next End Sub

Application.Columns(4).Select

Application.Rows(5).Select

Application.Sheets.PrintOut

For iSheet = 1 To Application.Sheets.Count If Not IsEmpty(Application.Sheets(iSheet).UsedRange) Then Application.Sheets(iSheet).PrintOut copies:=1 End If Next iSheet

Worksheets("Sheet1").Activate With ActiveCell.Font .Bold = True .Italic = True End With

Sub AddChart() Charts.Add With ActiveChart .ChartType = xl3DColumn .SetSourceData Source:=Sheets("Sheet1").Range("B3:H15") .Location Where:=xlLocationAsObject, Name:="Monthly Sales" .HasTitle = True .ChartTitle.Characters.Text = Monthly Sales by Category End With End Sub

MsgBox "The name of the active sheet is " & ActiveSheet.Name

Sub CopyActiveSheet() Dim x As Integer x = InputBox("Enter number of times to copy active sheet") For numtimes = 1 To x ‘ Put copies in front of Sheet1. ActiveWorkbook.ActiveSheet.Copy _ Before:=ActiveWorkbook.Sheets("Sheet1") Next End Sub

MsgBox "The name of the active window is " & ActiveWindow.Caption

Sub PrintWorksheet() Application.ScreenUpdating = False Sheets("Sales").Select ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True Sheets("Expenses").Select ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True End Sub

MsgBox "The name of the active workbook is " & ActiveWorkbook.Name

Sub CalcBook() Dim wks As Worksheet Application.Calculation = xlManual For Each wks In ActiveWorkbook.Worksheets wks.Calculate Next Set wks = Nothing End Sub

MsgBox Application.ActiveWindow.RangeSelection.Address

Range("A1").Select MsgBox Left(ActiveWindow.RangeSelection.Name.Name, 3)

ActiveWindow.RangeSelection.Name.Name

Worksheets("Sheet1").Activate Selection.Clear

NumRows = 0 For Each area In Selection.Areas NumRows = NumRows + area.Rows.Count Next area

Sub Count_Selection() Dim cell As Object Dim count As Integer count = 0 For Each cell In Selection count = count + 1 Next cell MsgBox count & " item(s) selected" End Sub

Dim FileNum As Integer FileNum = 0 For Each file in Files ‘ Do something here. Application.StatusBar = "Now processing File " & FileNum FileNum = FileNum + 1 Next

Application.StatusBar = False

Sub ShowStatusBarProgress() Dim i As Long Dim pctDone As Double Dim numSquares As Long Const MAXSQR As Long = 15 For i = 1 To 30 pctDone = i / 30 numSquares = pctDone * MAXSQR Application.StatusBar = Application.Rept(Chr(31), numSquares) Application.Wait Now + TimeSerial(0, 0, 1) Nexti Application.StatusBar = False End Sub

ThisWorkbook.Close SaveChanges:=False

Private oExcel As Excel.Application Private wbk As Excel.Workbook Sub CloseOpenWrkBks() Dim wrkb As Workbook For Each wbk In Application.Workbooks If wrkb.Name <> ThisWorkbook.Name Then wbk.Close True End If Next wbk ThisWorkbook.Close True End Sub

Sub OpenFile1( ) Dim bSuccess As Boolean Msgbox "Please locate the MonthlySales.xls file." bSuccess = Application.FindFile If Not bSuccess Then Msgbox "File not open." End If End Sub

Sub OpenFile2( ) Application.Dialogs(XlBuiltInDialog.xlDialogOpen).Show arg1:="Book1.xls" End Sub

GetOpenFilename(FileFilter, FilterIndex, Title, ButtonText, MultiSelect)

Dim fileToOpen As String fileToOpen = Application.GetOpenFilename("Text Files (*.txt), *.txt") If fileToOpen <> "" Then MsgBox "Open " & fileToOpen End If

InputBox(Prompt, Title, Default, Left, Top, HelpFile, HelpContextID, Type)

Set myRange = Application.InputBox(prompt := "Sample", type := 8)

Sub PrintActiveSheet() Dim TotalCopies As Long, NumCopies As Long Dim sPrompt As String, sTitle As String sPrompt = "How many copies do you want?" sTitle = "Prints the active sheet" TotalCopies = Application.InputBox(Prompt:=sPrompt, Title:=sTitle, Default:=1, Type:=1) For NumCopies = 1 To TotalCopies ActiveSheet.PrintOut Next NumCopies End Sub

Run(Macro, Arg1, , Arg30)

Sub UseRunMethod() Dim wks As Worksheet Dim rng As Range Set wks = Worksheets("Sheet2") Set rng = wks.Range("A1:A10") Application.Run "MyProc ", rng ‘ You could accomplish the same thing with: ‘ Call MyProc(rng) End Sub Sub MyProc(rng As Range) With rng.Font .Bold = True End With EndSub

Public WithEvents Apply As Application

Private Sub Apply_WorkbookOpen(ByVal Wb As Workbook) MsgBox "你打开了工作簿。" End Sub

Private Sub Appl_WorkbookBeforeClose(ByVal Wb As Workbook, Cancel As Boolean) MsgBox "你关闭了工作簿。" End Sub

Dim ApplicationClass As New AppEventClass

Private Sub Workbook_Open() Set ApplicationClass.Appl = Application End Sub

Sub DeleteSheet() Application.DisplayAlerts = False ActiveSheet.Delete Application.DisplayAlerts = True End Sub

Sub SaveWorksheet() Application.DisplayAlerts = False ActiveWorkbook.SaveAs "C:MonthlySales.xls" Application.DisplayAlerts = True End Sub

Sub SKeys() Range("A1:D15").Copy ‘ Copy the range. SendKeys "% n", True ‘ Minimize Excel. Shell "notepad.exe", vbNormalFocus ‘ Start Notepad. SendKeys "^V", True ‘ Past the range data into Notepad. SendKeys "?", True ‘ Specify SaveAs. SendKeys "SalesData.txt", True ‘ Provide a file name. SendKeys "%S", True ‘ Save the file. Close notepad End Sub

Application.OnTime(EarliestTime, Procedure, LatestTime, Schedule)

Application.OnTime EarliestTime:= Now + TimeValue("00:05:00), _ Procedure := "YourProc"

Application.OnTime _ EarliestTime:=TimeValue("12:00:00"), _ Procedure:="YourProc"

Private Sub Workbook_Open() Application.OnTime Now + TimeValue("00:05:00"), "AutoSave" End Sub Private Sub Workbook_BeforeClose(Cancel AsBoolean) On Error Resume Next Application.OnTime Now + TimeValue("00:05:00"), "CleanUp", , False End Sub

Sub CreateNewWorkbook1() MsgBox "将创建一个新工作簿." Workbooks.Add End Sub

Sub CreateNewWorkbook2() Dim wb As Workbook Dim ws As Worksheet Dim i As Long MsgBox "将创建一个新工作簿,并预设工作表格式." Set wb = Workbooks.AddSet ws = wb.Sheets(1) ws.Name = "产品汇总表" ws.Cells(1, 1) = "序号" ws.Cells(1, 2) = "产品名称" ws.Cells(1, 3) = "产品数量" For i = 2 To 10 ws.Cells(i, 1) = i - 1 Next i End Sub

Sub testNewWorkbook() MsgBox "创建一个带有10个工作表的新工作簿" Dim wb As Workbook Set wb = NewWorkbook(10) End Sub Function NewWorkbook(wsCount AsInteger) As Workbook ‘创建带有由变量wsCount提定数量工作表的工作簿，工作表数在1至255之间 Dim OriginalWorksheetCount As Long Set NewWorkbook = Nothing IfwsCount < 1 Or wsCount > 255 Then Exit Function OriginalWorksheetCount = Application.SheetsInNewWorkbook Application.SheetsInNewWorkbook = wsCount Set NewWorkbook = Workbooks.Add Application.SheetsInNewWorkbook = OriginalWorksheetCount End Function

Workbooks.Open(FileName, UpdateLinks, ReadOnly, Format, Password, WriteResPassword, IgnoreReadOnlyRecommended, Origin, Delimiter, Editable, Notify, Converter, AddToMru, Local, CorruptLoad)

Sub openWorkbook2() Dim fname As String MsgBox "将D盘中的<测试.xls>工作簿以只读方式打开" fname = "D:测试.xls" Workbooks.Open Filename:=fname, ReadOnly:=True End Sub

Workbooks.Item(1)

Workbooks(1)

Workbooks("MyBook.xlsx")

Workbooks("Book2")

Workbooks("Book2.xlsx")

Workbooks("MyWorkbook").Activate

Workbooks.Count

Function MyName() As String MyName = ThisWorkbook.Name End Function

Function MyName() As String MyName = ThisWorkbook.Name End Function

Sub testGeneralWorkbookInfo() MsgBox "本工作簿的名称为" & ActiveWorkbook.Name MsgBox "本工作簿带完整路径的名称为" & ActiveWorkbook.FullName MsgBox "本工作簿对象的代码名为" & ActiveWorkbook.CodeName MsgBox "本工作簿的路径为" & ActiveWorkbook.Path If ActiveWorkbook.ReadOnly Then MsgBox "本工作簿已经是以只读方式打开" Else MsgBox "本工作簿可读写." End If If ActiveWorkbook.Saved Then MsgBox "本工作簿已保存." Else MsgBox "本工作簿需要保存." End If EndSub

Workbook.Save

Sub SaveAllWorkbooks() Dim wbk As Workbook For Each wbk In Workbooks If wbk.Path <> "" Then wbk.Save Next wbk End Sub

Workbook.SaveAs(FileName, FileFormat, Password, WriteResPassword, ReadOnlyRecommended, CreateBackup, AccessMode, ConflictResolution, AddToMru, TextCodepage, TextVisualLayout, Local)

Sub AddSaveAsNewWorkbook() Dim Wk As Workbook Set Wk = Workbooks.Add Application.DisplayAlerts = False Wk.SaveAs Filename:="D:SalesData.xlsx"End Sub

Sub SaveWorkbook2() Dim oldName As String, newName As String Dim folderName As String, fname As String oldName = ActiveWorkbook.Name newName = "new" & oldName MsgBox "将<" & oldName & ">以<" & newName & ">的名称保存" folderName = Application.DefaultFilePath fname = folderName & "" & newName ActiveWorkbook.SaveAs fname End Sub

Sub CreateBak1() MsgBox "保存工作簿并建立备份工作簿" ActiveWorkbook.SaveAs CreateBackup:=True End Sub

Sub CreateBak2() MsgBox "保存工作簿时,若已建立了备份,则将出现包含True的信息框,否则出现False." MsgBox ActiveWorkbook.CreateBackup End Sub

Workbook.SaveCopyAs(Filename)

Sub SaveWorkbookBackup() Dim awb As Workbook, BackupFileName As String, i As Integer, OK As Boolean If TypeName(ActiveWorkbook) = "Nothing"Then Exit Sub Set awb = ActiveWorkbook If awb.Path = "" Then Application.Dialogs(xlDialogSaveAs).Show Else BackupFileName = awb.FullName i = 0While InStr(i + 1, BackupFileName, ".") > 0 i = InStr(i + 1, BackupFileName, ".") Wend If i > 0 Then BackupFileName = Left(BackupFileName, i - 1) BackupFileName = BackupFileName & ".bak" OK = False On Error GoTo NotAbleToSave With awb Application.StatusBar = "正在保存工作簿..." .Save Application.StatusBar = "正在备份工作簿..." .SaveCopyAs BackupFileName OK = True End With End If NotAbleToSave: Set awb = Nothing Application.StatusBar = False If Not OK Then MsgBox "备份工作簿未保存!", vbExclamation, ThisWorkbook.Name End If End Sub

Sub SaveWorkbookBackupToFloppyD() Dim awb As Workbook, BackupFileName As String, i As Integer, OK As Boolean If TypeName(ActiveWorkbook) = "Nothing" Then Exit Sub Set awb = ActiveWorkbook If awb.Path = "" Then Application.Dialogs(xlDialogSaveAs).Show Else BackupFileName = awb.Name OK = False On Error GoTo NotAbleToSave If Dir("D:" & BackupFileName) <> "" Then Kill "D:" & BackupFileName End If With awb Application.StatusBar = "正在保存工作簿..." .Save Application.StatusBar = "正在备份工作簿..." .SaveCopyAs "D:" & BackupFileName OK = True End With End If NotAbleToSave: Set awb = Nothing Application.StatusBar = False If Not OK Then MsgBox "备份工作簿未保存!", vbExclamation, ThisWorkbook.Name End If End Sub