Excel VBA Examples(2)
来源:百度文库 编辑:神马文学网 时间:2024/05/23 19:26:23
You should create a reference to the Outlook Object Library in the VBEditor Send_Msg()Dim objOL As New Outlook.ApplicationDim objMail As MailItemSet objOL = New Outlook.ApplicationSet 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") & ".".DisplayEnd WithSet objMail = NothingSet objOL = NothingEnd Sub
Back
()Dim myVar As ShapesDim shp As ShapeSet myVar = Sheets(1).ShapesFor Each shp In myVarMsgBox "Index = " & shp.ZOrderPosition & vbCrLf & "Name = " _& shp.NameNextEnd Sub
Back
‘ You should create a reference to the Word Object Library in the VBEditor
()On Error GoTo errorHandlerDim wdApp As Word.ApplicationDim myDoc As Word.DocumentDim mywdRange As Word.RangeSet wdApp = New Word.ApplicationWith wdApp.Visible = True.WindowState = wdWindowStateMaximizeEnd 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 = TrueEnd WitherrorHandler:Set wdApp = NothingSet myDoc = NothingSet mywdRange = NothingEnd Sub
Back
()RandomizeStarWidth = 25StarHeight = 25 For i = 1 To 10TopPos = 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")DoEventsNext i Application.Wait Now + TimeValue("00:00:02")Set myShapes = Worksheets(1).ShapesFor Each shp In myShapesIf Left(shp.Name, 9) = "AutoShape" Thenshp.DeleteApplication.Wait Now + TimeValue("00:00:01")End IfNextWorksheets(1).Shapes("Message").Visible = TrueEnd Sub
Back
‘ 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
‘ 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 RangeDim x As Integer, i As Integer, numofRows As IntegerSet topCel = Range("A2")Set bottomCel = Range("A65536").End(xlUp)If topCel.Row > bottomCel.Row Then End ‘ test if source range is emptySet sourceRange = Range(topCel, bottomCel)Set targetRange = Range("D2")numofRows = sourceRange.Rows.Countx = 1For i = 1 To numofRowsIf Application.IsNumber(sourceRange(i)) ThenIf sourceRange(i) > 1300000 ThentargetRange(x) = sourceRange(i)x = x + 1End IfEnd IfNextEnd Sub
Back
CountNonBlankCells() ‘Returns a count of non-blank cells in a selectionDim 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 SubSub CountNonBlankCells2() ‘Returns a count of non-blank cells in a selectionDim 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 SubSub CountAllCells ‘Returns a count of all cells in a selectionDim myCount As Integer ‘using the Selection and Count propertiesmyCount = Selection.CountMsgBox "The total number of cell(s) in this selection is : "_& myCount, vbInformation, "Count Cells"End SubSub CountRows() ‘Returns a count of the number of rows in a selectionDim myCount As Integer ‘using the Selection & Count properties & the Rows methodmyCount = Selection.Rows.CountMsgBox "This selection contains " & myCount & " row(s)", vbInformation, "Count Rows"End SubSub CountColumns() ‘Returns a count of the number of columns in a selectionDim myCount As Integer ‘using the Selection & Count properties & the Columns methodmyCount = Selection.Columns.CountMsgBox "This selection contains " & myCount & " columns", vbInformation, "Count Columns"End SubSub CountColumnsMultipleSelections() ‘Counts columns in a multiple selectionAreaCount = Selection.Areas.CountIf AreaCount <= 1 ThenMsgBox "The selection contains " & _Selection.Columns.Count & " columns."ElseFor i = 1 To AreaCountMsgBox "Area " & i & " of the selection contains " & _Selection.Areas(i).Columns.Count & " columns."Next iEnd IfEnd SubSub addAmtAbs()Set myRange = Range("Range1") ‘ Substitute your range heremycount = Application.Count(myRange)ActiveCell.Formula = "=SUM(B1:B" & mycount & ")" ‘ Substitute your cell address hereEnd SubSub addAmtRel()Set myRange = Range("Range1") ‘ Substitute your range heremycount = Application.Count(myRange)ActiveCell.Formula = "=SUM(R[" & -mycount & "]C:R[-1]C)" ‘ Substitute your cell address hereEnd Sub
Back
SelectDown()Range(ActiveCell, ActiveCell.End(xlDown)).SelectEnd SubSub Select_from_ActiveCell_to_Last_Cell_in_Column()Dim topCel As RangeDim bottomCel As RangeOn Error GoTo errorHandlerSet topCel = ActiveCellSet bottomCel = Cells((65536), topCel.Column).End(xlUp)If bottomCel.Row >= topCel.Row ThenRange(topCel, bottomCel).SelectEnd IfExit SuberrorHandler:MsgBox "Error no. " & Err & " - " & ErrorEnd SubSub SelectUp()Range(ActiveCell, ActiveCell.End(xlUp)).SelectEnd SubSub SelectToRight()Range(ActiveCell, ActiveCell.End(xlToRight)).SelectEnd SubSub SelectToLeft()Range(ActiveCell, ActiveCell.End(xlToLeft)).SelectEnd SubSub SelectCurrentRegion()ActiveCell.CurrentRegion.SelectEnd SubSub SelectActiveArea()Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).SelectEnd SubSub SelectActiveColumn()If IsEmpty(ActiveCell) Then Exit SubOn Error Resume NextIf 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).SelectEnd SubSub SelectActiveRow()If IsEmpty(ActiveCell) Then Exit SubOn Error Resume NextIf 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).SelectEnd SubSub SelectEntireColumn()Selection.EntireColumn.SelectEnd SubSub SelectEntireRow()Selection.EntireRow.SelectEnd SubSub SelectEntireSheet()Cells.SelectEnd SubSub ActivateNextBlankDown()ActiveCell.Offset(1, 0).SelectDo While Not IsEmpty(ActiveCell)ActiveCell.Offset(1, 0).SelectLoopEnd SubSub ActivateNextBlankToRight()ActiveCell.Offset(0, 1).SelectDo While Not IsEmpty(ActiveCell)ActiveCell.Offset(0, 1).SelectLoopEnd SubSub 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).SelectEnd SubSub 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).SelectEnd SubSub SelCurRegCopy()Selection.CurrentRegion.SelectSelection.CopyRange("A17").Select ‘ Substitute your range hereActiveSheet.PasteApplication.CutCopyMode = FalseEnd Sub
Back
Back
()Dim myVar As ShapesDim shp As ShapeSet myVar = Sheets(1).ShapesFor Each shp In myVarMsgBox "Index = " & shp.ZOrderPosition & vbCrLf & "Name = " _& shp.NameNextEnd Sub
Back
‘ You should create a reference to the Word Object Library in the VBEditor
()On Error GoTo errorHandlerDim wdApp As Word.ApplicationDim myDoc As Word.DocumentDim mywdRange As Word.RangeSet wdApp = New Word.ApplicationWith wdApp.Visible = True.WindowState = wdWindowStateMaximizeEnd 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 = TrueEnd WitherrorHandler:Set wdApp = NothingSet myDoc = NothingSet mywdRange = NothingEnd Sub
Back
()RandomizeStarWidth = 25StarHeight = 25 For i = 1 To 10TopPos = 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")DoEventsNext i Application.Wait Now + TimeValue("00:00:02")Set myShapes = Worksheets(1).ShapesFor Each shp In myShapesIf Left(shp.Name, 9) = "AutoShape" Thenshp.DeleteApplication.Wait Now + TimeValue("00:00:01")End IfNextWorksheets(1).Shapes("Message").Visible = TrueEnd Sub
Back
‘ 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
‘ 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 RangeDim x As Integer, i As Integer, numofRows As IntegerSet topCel = Range("A2")Set bottomCel = Range("A65536").End(xlUp)If topCel.Row > bottomCel.Row Then End ‘ test if source range is emptySet sourceRange = Range(topCel, bottomCel)Set targetRange = Range("D2")numofRows = sourceRange.Rows.Countx = 1For i = 1 To numofRowsIf Application.IsNumber(sourceRange(i)) ThenIf sourceRange(i) > 1300000 ThentargetRange(x) = sourceRange(i)x = x + 1End IfEnd IfNextEnd Sub
Back
CountNonBlankCells() ‘Returns a count of non-blank cells in a selectionDim 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 SubSub CountNonBlankCells2() ‘Returns a count of non-blank cells in a selectionDim 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 SubSub CountAllCells ‘Returns a count of all cells in a selectionDim myCount As Integer ‘using the Selection and Count propertiesmyCount = Selection.CountMsgBox "The total number of cell(s) in this selection is : "_& myCount, vbInformation, "Count Cells"End SubSub CountRows() ‘Returns a count of the number of rows in a selectionDim myCount As Integer ‘using the Selection & Count properties & the Rows methodmyCount = Selection.Rows.CountMsgBox "This selection contains " & myCount & " row(s)", vbInformation, "Count Rows"End SubSub CountColumns() ‘Returns a count of the number of columns in a selectionDim myCount As Integer ‘using the Selection & Count properties & the Columns methodmyCount = Selection.Columns.CountMsgBox "This selection contains " & myCount & " columns", vbInformation, "Count Columns"End SubSub CountColumnsMultipleSelections() ‘Counts columns in a multiple selectionAreaCount = Selection.Areas.CountIf AreaCount <= 1 ThenMsgBox "The selection contains " & _Selection.Columns.Count & " columns."ElseFor i = 1 To AreaCountMsgBox "Area " & i & " of the selection contains " & _Selection.Areas(i).Columns.Count & " columns."Next iEnd IfEnd SubSub addAmtAbs()Set myRange = Range("Range1") ‘ Substitute your range heremycount = Application.Count(myRange)ActiveCell.Formula = "=SUM(B1:B" & mycount & ")" ‘ Substitute your cell address hereEnd SubSub addAmtRel()Set myRange = Range("Range1") ‘ Substitute your range heremycount = Application.Count(myRange)ActiveCell.Formula = "=SUM(R[" & -mycount & "]C:R[-1]C)" ‘ Substitute your cell address hereEnd Sub
Back
SelectDown()Range(ActiveCell, ActiveCell.End(xlDown)).SelectEnd SubSub Select_from_ActiveCell_to_Last_Cell_in_Column()Dim topCel As RangeDim bottomCel As RangeOn Error GoTo errorHandlerSet topCel = ActiveCellSet bottomCel = Cells((65536), topCel.Column).End(xlUp)If bottomCel.Row >= topCel.Row ThenRange(topCel, bottomCel).SelectEnd IfExit SuberrorHandler:MsgBox "Error no. " & Err & " - " & ErrorEnd SubSub SelectUp()Range(ActiveCell, ActiveCell.End(xlUp)).SelectEnd SubSub SelectToRight()Range(ActiveCell, ActiveCell.End(xlToRight)).SelectEnd SubSub SelectToLeft()Range(ActiveCell, ActiveCell.End(xlToLeft)).SelectEnd SubSub SelectCurrentRegion()ActiveCell.CurrentRegion.SelectEnd SubSub SelectActiveArea()Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).SelectEnd SubSub SelectActiveColumn()If IsEmpty(ActiveCell) Then Exit SubOn Error Resume NextIf 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).SelectEnd SubSub SelectActiveRow()If IsEmpty(ActiveCell) Then Exit SubOn Error Resume NextIf 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).SelectEnd SubSub SelectEntireColumn()Selection.EntireColumn.SelectEnd SubSub SelectEntireRow()Selection.EntireRow.SelectEnd SubSub SelectEntireSheet()Cells.SelectEnd SubSub ActivateNextBlankDown()ActiveCell.Offset(1, 0).SelectDo While Not IsEmpty(ActiveCell)ActiveCell.Offset(1, 0).SelectLoopEnd SubSub ActivateNextBlankToRight()ActiveCell.Offset(0, 1).SelectDo While Not IsEmpty(ActiveCell)ActiveCell.Offset(0, 1).SelectLoopEnd SubSub 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).SelectEnd SubSub 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).SelectEnd SubSub SelCurRegCopy()Selection.CurrentRegion.SelectSelection.CopyRange("A17").Select ‘ Substitute your range hereActiveSheet.PasteApplication.CutCopyMode = FalseEnd Sub
Back
Excel VBA Examples(2)
Excel VBA Examples(2)
Quick Excel Chart VBA Examples
Quick Excel Chart VBA Examples
Excel VBA编程的常用代码2
EXCEL VBA 基础
EXCEL VBA 基础
Excel VBA完全手册
Excel VBA语句
EXCEL VBA 基础qeq
EXCEL VBA 基础1
EXCEL VBA 基础11
Excel VBA入门语句
EXCEL VBA 基础
EXCEL VBA 基础
Excel VBA排序算法
EXCEL VBA 基础
Excel VBA入门语句
Excel VBA入门语句
EXCEL VBA 基础
EXCEL 编程(VBA)
examples
自学资料(Excel VBA)[收集整理2]
自学资料(Excel VBA)[收集整理2]