原版VBA例程 [复制链接]

我在网上找的： 原版VBA例程[英文],我只作了些简短的中文注释,望对各位有点用处,---------墨伯,于2004/04/18

Microsoft Excel VBA Examples '''发邮件: ' You should create a reference to the Outlook Object Library in the VBEditor Sub Send_Msg() Dim objOL As New Outlook.Application Dim objMail As MailItemSet objOL = New Outlook.Application Set objMail = objOL.CreateItem(olMailItem)With objMail .To = "name@domain.com" .Subject = "Automated Mail Response" .Body = "This is an automated message from Excel. " & _ "The cost of the item that you inquired about is: " & _ Format(Range("A1").Value, "$ #,###.#0") & "." .Display End WithSet objMail = Nothing Set objOL = Nothing End Sub Back

'''形状的序号和名称:Sub Shape_Index_Name() Dim myVar As Shapes Dim shp As Shape Set myVar = Sheets(1).ShapesFor Each shp In myVar MsgBox "Index = " & shp.ZOrderPosition & vbCrLf & "Name = " _ & shp.Name NextEnd Sub Back

'''创建WORD文档资料' You should create a reference to the Word Object Library in the VBEditor Sub Open_MSWord() On Error GoTo errorHandler Dim wdApp As Word.Application Dim myDoc As Word.Document Dim mywdRange As Word.Range Set wdApp = New Word.ApplicationWith wdApp .Visible = True .WindowState = wdWindowStateMaximize End WithSet myDoc = wdApp.Documents.AddSet mywdRange = myDoc.Words(1)With mywdRange .Text = Range("F6") & " This text is being used to test subroutine." & _ " More meaningful text to follow." .Font.Name = "Comic Sans MS" .Font.Size = 12 .Font.ColorIndex = wdGreen .Bold = True End WitherrorHandler:Set wdApp = Nothing Set myDoc = Nothing Set mywdRange = Nothing End Sub Back

'''显示小星星:Sub ShowStars() Randomize StarWidth = 25 StarHeight = 25 For i = 1 To 10 TopPos = Rnd() * (ActiveWindow.UsableHeight - StarHeight) LeftPos = Rnd() * (ActiveWindow.UsableWidth - StarWidth) Set NewStar = ActiveSheet.Shapes.AddShape _ (msoShape4pointStar, LeftPos, TopPos, StarWidth, StarHeight) NewStar.Fill.ForeColor.SchemeColor = Int(Rnd() * 56) Application.Wait Now + TimeValue("00:00:01") DoEvents Next i Application.Wait Now + TimeValue("00:00:02") Set myShapes = Worksheets(1).Shapes For Each shp In myShapes If Left(shp.Name, 9) = "AutoShape" Then shp.Delete Application.Wait Now + TimeValue("00:00:01") End If Next Worksheets(1).Shapes("Message").Visible = True End Sub Back

'''对某些单元格进行上锁: ' This sub looks at every cell on the worksheet and ' if the cell DOES NOT have a formula, a date or text ' and the cell IS numeric, it unlocks the cell and ' makes the font blue. For everything else, it locks ' the cell and makes the font black. It then protects ' the worksheet. ' This has the effect of allowing someone to edit the ' numbers but they cannot change the text, dates or ' formulas. Sub Set_Protection() On Error GoTo errorHandler Dim myDoc As Worksheet Dim cel As Range Set myDoc = ActiveSheet myDoc.UnProtect For Each cel In myDoc.UsedRange If Not cel.HasFormula And _ Not TypeName(cel.Value) = "Date" And _ Application.IsNumber(cel) Then cel.Locked = False cel.Font.ColorIndex = 5 Else cel.Locked = True cel.Font.ColorIndex = xlColorIndexAutomatic End If Next myDoc.Protect Exit Sub errorHandler: MsgBox Error End Sub Back

'''拣数并复制: ' 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 Back

'''统计非空单元格:Sub CountNonBlankCells() 'Returns a count of non-blank cells in a selection Dim myCount As Integer 'using the CountA ws function (all non-blanks) myCount = Application.CountA(Selection) MsgBox "The number of non-blank cell(s) in this selection is : "_ & myCount, vbInformation, "Count Cells" End Sub

'''统计非空单元格:Sub CountNonBlankCells2()'Returns a count of non-blank cells in a selection Dim myCount As Integer 'using the Count ws function (only counts numbers, no text) myCount = Application.Count(Selection) MsgBox "The number of non-blank cell(s) containing numbers is : "_ & myCount, vbInformation, "Count Cells" End Sub

'''统计单元格:Sub CountAllCells 'Returns a count of all cells in a selection Dim myCount As Integer 'using the Selection and Count properties myCount = Selection.Count MsgBox "The total number of cell(s) in this selection is : "_ & myCount, vbInformation, "Count Cells" End Sub

'''统计行数:Sub CountRows() 'Returns a count of the number of rows in a selection Dim myCount As Integer 'using the Selection & Count properties & the Rows method myCount = Selection.Rows.Count MsgBox "This selection contains " & myCount & " row(s)", vbInformation, "Count Rows" End Sub

'''统计列数:Sub CountColumns() 'Returns a count of the number of columns in a selection Dim myCount As Integer 'using the Selection & Count properties & the Columns method myCount = Selection.Columns.Count MsgBox "This selection contains " & myCount & " columns", vbInformation, "Count Columns" End Sub

'''统计多选处的列数:Sub CountColumnsMultipleSelections() 'Counts columns in a multiple selection AreaCount = Selection.Areas.Count If AreaCount <= 1 Then MsgBox "The selection contains " & _ Selection.Columns.Count & " columns." Else For i = 1 To AreaCount MsgBox "Area " & i & " of the selection contains " & _ Selection.Areas(i).Columns.Count & " columns." Next i End If End Sub

'''绝对位置求和:Sub addAmtAbs() Set myRange = Range("Range1") ' Substitute your range here mycount = Application.Count(myRange) ActiveCell.Formula = "=SUM(B1:B" & mycount & ")" ' Substitute your cell address here End Sub

'''相对位置求和:Sub addAmtRel() Set myRange = Range("Range1") ' Substitute your range here mycount = Application.Count(myRange) ActiveCell.Formula = "=SUM(R[" & -mycount & "]C:R[-1]C)" ' Substitute your cell address here End Sub Back

'''向下选中: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 Back

 Microsoft Excel VBA Examples

'''循环句法: '-----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

'''WITH之用法: '-----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

Back

' The distinction between Hide(False) and xlVeryHidden: ' Visible = xlVeryHidden - Sheet/Unhide is grayed out. To unhide sheet, you must set ' the Visible property to True. ' Visible = Hide(or False) - Sheet/Unhide is not grayed out

''隐藏' To hide specific worksheet Sub Hide_WS1() Worksheets(2).Visible = Hide ' you can use Hide or False End Sub

''隐藏: ' To make a specific worksheet very hidden Sub Hide_WS2() Worksheets(2).Visible = xlVeryHidden End Sub

''显示: ' To unhide a specific worksheet Sub UnHide_WS() Worksheets(2).Visible = True End Sub

'''栓住两面派: ' To toggle between hidden and visible Sub Toggle_Hidden_Visible() Worksheets(2).Visible = Not Worksheets(2).Visible End Sub

'''全部显示: ' To set the visible property to True on ALL sheets in workbook Sub Un_Hide_All() Dim sh As Worksheet For Each sh In Worksheets sh.Visible = True Next End Sub

' To set the visible property to xlVeryHidden on ALL sheets in workbook. ' Note: The last "hide" will fail because you can not hide every sheet ' in a work book. '''全部深藏匿Sub xlVeryHidden_All_Sheets() On Error Resume Next Dim sh As Worksheet For Each sh In Worksheets sh.Visible = xlVeryHidden Next End Sub

Back

'///....To find and select a range of dates based on the month and year only....\\\

'''查找:Sub FindDates() On Error GoTo errorHandler Dim startDate As String Dim stopDate As String Dim startRow As Integer Dim stopRow As Integer startDate = InputBox("Enter the Start Date: (mm/dd/yy)") If startDate = "" Then End stopDate = InputBox("Enter the Stop Date: (mm/dd/yy)") If stopDate = "" Then End startDate = Format(startDate, "mm/??/yy") stopDate = Format(stopDate, "mm/??/yy") startRow = Worksheets("Table").Columns("A").Find(startDate, _ lookin:=xlValues, lookat:=xlWhole).Row stopRow = Worksheets("Table").Columns("A").Find(stopDate, _ lookin:=xlValues, lookat:=xlWhole).Row Worksheets("Table").Range("A" & startRow & ":A" & stopRow).Copy _ destination:=Worksheets("Report").Range("A1") End errorHandler: MsgBox "There has been an error: " & Error() & Chr(13) _ & "Ending Sub.......Please try again", 48 End Sub Back

QQ空间

腾讯微博

腾讯朋友

收藏1

有用0

无用0

转发到微博

举报

• 等级 4EH高级

积分排行

706

帖子

596

精华

4

分享

0

• 串个门
• 加好友
• 打招呼
• 发消息

继续：

'''数组之应用:Sub MyTestArray() Dim myCrit(1 To 4) As String ' Declaring array and setting bounds Dim Response As String Dim i As Integer Dim myFlag As Boolean myFlag = False

' To fill array with values myCrit(1) = "A" myCrit(2) = "B" myCrit(3) = "C" myCrit(4) = "D"

Do Until myFlag = True Response = InputBox("Please enter your choice: (i.e. A,B,C or D)") ' Check if Response matches anything in array For i = 1 To 4 'UCase ensures that Response and myCrit are the same case If UCase(Response) = UCase(myCrit(i)) Then myFlag = True: Exit For End If Next i Loop End Sub Back

'''替换'// This sub will replace information in all sheets of the workbook \'//...... Replace "old stuff" and "new stuff" with your info ......\Sub ChgInfo() Dim Sht As Worksheet For Each Sht In Worksheets Sht.Cells.Replace What:="old stuff", _ Replacement:="new stuff", LookAt:=xlPart, MatchCase:=False Next End Sub Back

'''改文本为数值: ' This sub will move the sign from the right-hand side thus changing a text string into a value. Sub MoveMinus() On Error Resume Next Dim cel As Range Dim myVar As Range Set myVar = Selection

For Each cel In myVar If Right((Trim(cel)), 1) = "-" Then cel.Value = cel.Value * 1 End If Next With myVar .NumberFormat = "#,##0.00_);[Red](#,##0.00)" .Columns.AutoFit End With End Sub Back

'''参数传输: ' This sub calls the DetermineUsedRange sub and passes ' the empty argument "usedRng". ''' Sub CallDetermineUsedRange() On Error Resume Next Dim usedRng As Range DetermineUsedRange usedRng MsgBox usedRng.Address End Sub

' This sub receives the empty argument "usedRng" and determines ' the populated cells of the active worksheet, which is stored ' in the variable "theRng", and passed back to the calling sub.

Sub DetermineUsedRange(ByRef theRng As Range) Dim FirstRow As Integer, FirstCol As Integer, _ LastRow As Integer, LastCol As Integer On Error GoTo handleError FirstRow = Cells.Find(What:="*", _ SearchDirection:=xlNext, _ SearchOrder:=xlByRows).Row FirstCol = Cells.Find(What:="*", _ SearchDirection:=xlNext, _ SearchOrder:=xlByColumns).Column LastRow = Cells.Find(What:="*", _ SearchDirection:=xlPrevious, _ SearchOrder:=xlByRows).Row LastCol = Cells.Find(What:="*", _ SearchDirection:=xlPrevious, _ SearchOrder:=xlByColumns).Column Set theRng = Range(Cells(FirstRow, FirstCol), _ Cells(LastRow, LastCol)) handleError: End Sub Back

'Copies only the weekdates from a range of dates. '''从区域中只复制星期日的数据:Sub EnterDates() Columns(3).Clear Dim startDate As String, stopDate As String, startCel As Integer, stopCel As Integer, dateRange As Range On Error Resume NextDo startDate = InputBox("Please enter Start Date: Format(mm/dd/yy)", "START DATE") If startDate = "" Then End Loop Until startDate = Format(startDate, "mm/dd/yy") _ Or startDate = Format(startDate, "m/d/yy")Do stopDate = InputBox("Please enter Stop Date: Format(mm/dd/yy)", "STOP DATE") If stopDate = "" Then End Loop Until stopDate = Format(stopDate, "mm/dd/yy") _ Or stopDate = Format(stopDate, "m/d/yy")startDate = Format(startDate, "mm/dd/yy") stopDate = Format(stopDate, "mm/dd/yy")startCel = Sheets(1).Columns(1).Find(startDate, LookIn:=xlValues, lookat:=xlWhole).Row stopCel = Sheets(1).Columns(1).Find(stopDate, LookIn:=xlValues, lookat:=xlWhole).RowOn Error GoTo errorHandlerSet dateRange = Range(Cells(startCel, 1), Cells(stopCel, 1))Call CopyWeekDates(dateRange) ' Passes the argument dateRange to the CopyWeekDates sub.Exit Sub errorHandler: If startCel = 0 Then MsgBox "Start Date is not in table.", 64 If stopCel = 0 Then MsgBox "Stop Date is not in table.", 64 End Sub

Sub CopyWeekDates(myRange) Dim myDay As Variant, cnt As Integer cnt = 1 For Each myDay In myRange If WeekDay(myDay, vbMonday) < 6 Then With Range("C1")(cnt) .NumberFormat = "mm/dd/yy" .Value = myDay End With cnt = cnt + 1 End If Next End Sub Back Microsoft Excel VBA Examples

'''列出公式: Sub ListFormulas() Dim counter As Integer Dim i As Variant Dim sourcerange As Range Dim destrange As Range Set sourcerange = Selection.SpecialCells(xlFormulas) Set destrange = Range("M1") ' Substitute your range here destrange.CurrentRegion.ClearContents destrange.Value = "Address" destrange.Offset(0, 1).Value = "Formula" If Selection.Count > 1 Then For Each i In sourcerange counter = counter + 1 destrange.Offset(counter, 0).Value = i.Address destrange.Offset(counter, 1).Value = "'" & i.Formula Next ElseIf Selection.Count = 1 And Left(Selection.Formula, 1) = "=" Then destrange.Offset(1, 0).Value = Selection.Address destrange.Offset(1, 1).Value = "'" & Selection.Formula Else MsgBox "This cell does not contain a formula" End If destrange.CurrentRegion.EntireColumn.AutoFit End Sub

Sub AddressFormulasMsgBox() 'Displays the address and formula in message box For Each Item In Selection If Mid(Item.Formula, 1, 1) = "=" Then MsgBox "The formula in " & Item.Address(rowAbsolute:=False, _ columnAbsolute:=False) & " is: " & Item.Formula, vbInformation End If Next End Sub Back

'''删除区域名:Sub DeleteRangeNames() Dim rName As Name For Each rName In ActiveWorkbook.Names rName.Delete Next rName End Sub Back

'''表格的类型:Sub TypeSheet() MsgBox "This sheet is a " & TypeName(ActiveSheet) End SubBack

'''增加工作表,并检查已存在的工作表:Sub AddSheetWithNameCheckIfExists() Dim ws As Worksheet Dim newSheetName As String newSheetName = Sheets(1).Range("A1") ' Substitute your range here For Each ws In Worksheets If ws.Name = newSheetName Or newSheetName = "" Or IsNumeric(newSheetName) Then MsgBox "Sheet already exists or name is invalid", vbInformation Exit Sub End If Next Sheets.Add Type:="Worksheet" With ActiveSheet .Move after:=Worksheets(Worksheets.Count) .Name = newSheetName End With End Sub

'''增加工作表:Sub Add_Sheet() Dim wSht As Worksheet Dim shtName As String shtName = Format(Now, "mmmm_yyyy") For Each wSht In Worksheets If wSht.Name = shtName Then MsgBox "Sheet already exists...Make necessary " & _ "corrections and try again." Exit Sub End If Next wSht Sheets.Add.Name = shtName Sheets(shtName).Move After:=Sheets(Sheets.Count) Sheets("Sheet1").Range("A1:A5").Copy _ Sheets(shtName).Range("A1") End Sub

'''复制工作表:Sub Copy_Sheet() Dim wSht As Worksheet Dim shtName As String shtName = "NewSheet" For Each wSht In Worksheets If wSht.Name = shtName Then MsgBox "Sheet already exists...Make necessary " & _ "corrections and try again." Exit Sub End If Next wSht Sheets(1).Copy before:=Sheets(1) Sheets(1).Name = shtName Sheets(shtName).Move After:=Sheets(Sheets.Count) End Sub Back

'''初始化,赋予0值:Sub ResetValuesToZero2() For Each n In Worksheets("Sheet1").Range("WorkArea1") ' Substitute your information here If n.Value <> 0 Then n.Value = 0 End If Next n End Sub

'''置0: Sub ResetTest1() For Each n In Range("B1:G13") ' Substitute your range here If n.Value <> 0 Then n.Value = 0 End If Next n End Sub

'''是数字都置0: Sub ResetTest2() For Each n In Range("A16:G28") ' Substitute your range here If IsNumeric(n) Then n.Value = 0 End If Next n End Sub

'''置0: Sub ResetTest3() For Each amount In Range("I1:I13") ' Substitute your range here If amount.Value <> 0 Then amount.Value = 0 End If Next amount End Sub

'''置0: 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 Back

'''计算报酬:Sub CalcPay() On Error GoTo HandleError Dim hours Dim hourlyPay Dim payPerWeek hours = InputBox("Please enter number of hours worked", "Hours Worked") hourlyPay = InputBox("Please enter hourly pay", "Pay Rate") payPerWeek = CCur(hours * hourlyPay) MsgBox "Pay is: " & Format(payPerWeek, "$##,##0.00"), , "Total Pay" HandleError: End Sub Back

'''打印: 'To print header, control the font and to pull second line of header (the date) from worksheet Sub Printr() ActiveSheet.PageSetup.CenterHeader = "&""Arial,Bold Italic""&14My Report" & Chr(13) _ & Sheets(1).Range("A1") ActiveWindow.SelectedSheets.PrintOut Copies:=1 End Sub

Sub PrintRpt1() 'To control orientation Sheets(1).PageSetup.Orientation = xlLandscape Range("Report").PrintOut Copies:=1 End Sub

Sub PrintRpt2() 'To print several ranges on the same sheet - 1 copy Range("HVIII_3A2").PrintOut Range("BVIII_3").PrintOut Range("BVIII_4A").PrintOut Range("HVIII_4A2").PrintOut Range("BVIII_5A").PrintOut Range("BVIII_5B2").PrintOut Range("HVIII_5A2").PrintOut Range("HVIII_5B2").PrintOut End Sub

'To print a defined area, center horizontally, with 2 rows as titles, 'in portrait orientation and fitted to page wide and tall - 1 copy Sub PrintRpt3() With Worksheets("Sheet1").PageSetup .CenterHorizontally = True .PrintArea = "$A$3:$F$15" .PrintTitleRows = ("$A$1:$A$2") .Orientation = xlPortrait .FitToPagesWide = 1 .FitToPagesTall = 1 End With Worksheets("Sheet1").PrintOut End Sub Back

' This is a simple example of using the OnEntry property. The Auto_Open sub calls the Action ' sub.The font is set to bold in the ActiveCell if the value is >= 500. Thus if the value is >=500, ' then ActiveCell.Font.Bold = True. If the value is less than 500, then ActiveCell.Font.Bold = False.

' The Auto_Close sub "turns off" OnEntry. 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 Back

'These subs place the value (result) of a formula into a cell rather than the formula. '''捷径:Sub GetSum() ' using the shortcut approach [A1].Value = Application.Sum([E1:E15]) End Sub

Sub EnterChoice() Dim DBoxPick As Integer Dim InputRng As Range Dim cel As Range DBoxPick = DialogSheets(1).ListBoxes(1).Value Set InputRng = Columns(1).Rows

For Each cel In InputRng If cel.Value = "" Then cel.Value = Application.Index([InputData!StateList], DBoxPick, 1) End End If Next

End Sub Back

'''把名字送给已知的区域: ' To add a range name for known range Sub AddName1() ActiveSheet.Names.Add Name:="MyRange1", RefersT="=$A$1:$B$10" End Sub

'''把名字送给已选中的区域: ' To add a range name based on a selection Sub AddName2() ActiveSheet.Names.Add Name:="MyRange2", RefersT="=" & Selection.Address() End Sub

'''把名字送给已选中的区域: ' To add a range name based on a selection using a variable. Note: This is a shorter version Sub AddName3() Dim rngSelect As String rngSelect = Selection.Address ActiveSheet.Names.Add Name:="MyRange3", RefersT="=" & rngSelect End Sub

'''为选中的区域取名: ' To add a range name based on a selection. (The shortest version) Sub AddName4() Selection.Name = "MyRange4" End Sub Back

 Microsoft Excel VBA Examples

Events

'''事件:

The code for a sheet event is located in, or is called by, a procedure in the code section of the worksheet. Events that apply to the whole workbook are located in the code section of ThisWorkbook. Events are recursive. That is, if you use a Change Event and then change the contents of a cell with your code, this will innate another Change Event, and so on, depending on the code. To prevent this from happening, use: Application.EnableEvents = False at the start of your code Application.EnabeEvents = True at the end of your code

' This is a simple sub that changes what you type in a cell to upper case. Private Sub Worksheet_Change(ByVal Target As Excel.Range) Application.EnableEvents = False Target = UCase(Target) Application.EnableEvents = True End Sub

' This sub shows a UserForm if the user selects any cell in myRange Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) On Error Resume Next Set myRange = Intersect(Range("A1:A10"), Target) If Not myRange Is Nothing Then UserForm1.Show End If End Sub

' You should probably use this with the sub above to ensure ' that the user is outside of myRange when the sheet is activated. Private Sub Worksheet_Activate() Range("B1").Select End Sub

' In this example, Sheets("Table") contains, in Column A, a list of ' dates (for example Mar-97) and in Column B, an amount for Mar-97. ' If you enter Mar-97 in Sheet1, it places the amount for March in ' the cell to the right. (The sub below is in the code section of ' Sheet 1.)

Private Sub Worksheet_Change(ByVal Target As Excel.Range) On Error GoTo iQuitz Dim cel As Range, tblRange As Range Set tblRange = Sheets("Table").Range("A1:A48") Application.EnableEvents = False For Each cel In tblRange If UCase(cel) = UCase(Target) Then With Target(1, 2) .Value = cel(1, 2).Value .NumberFormat = "#,##0.00_);[Red](#,##0.00)" End With Columns(Target(1, 2).Column).AutoFit Exit For End If Next iQuitz: Application.EnableEvents = True End Sub

'If you select a cell in a column that contains values, the total 'of all the values in the column will show in the statusbar.

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) Dim myVar As Double myVar = Application.Sum(Columns(Target.Column)) If myVar <> 0 Then Application.StatusBar = Format(myVar, "###,###") Else Application.StatusBar = False End If End Sub More to come ....... I have just started this page. Back