现在的位置: 首页 > 综合 > 正文

VBA程序集(第1辑)

2013年10月18日 ⁄ 综合 ⁄ 共 6435字 ⁄ 字号 评论关闭

VBA程序集
(第1辑)

******************************************************
程序1(对工作簿的操作)
[程序功能] 关闭工作簿
[情形一] 关闭并保存所有工作簿
Option Explicit
Sub CloseAllWorkbooks()
  Dim Book As Workbook
  For Each Book In Workbooks
If Book.Name<>ThisWorkbook.Name Then
  Book.Close savechanges:=True
End If
  Next Book
  ThisWorkbook.Close savechanges:=True
End Sub

[情形二] 关闭工作簿并将它彻底删除
Option Explicit
Sub KillMe()
With ThisWorkbook
        .Saved = True
        .ChangeFileAccess Mode:=xlReadOnly
        Kill .FullName
        .Close False
End With
End Sub
[程序说明]
1、使用本程序时应注意,运行它将彻底删除工作簿。
2、本程序可用于:(1)工作簿到某时间需删除时;(2)没有工作簿权限,输入错误的密码时。

文档示例见UploadFiles/2006-6/66311071.rar

*****************************************************************

程序2(对单元格的操作)
[程序功能] 计算工作表中已使用单元格行列数
[方法一]
Sub 计算行数()  '计算工作表中已使用单元格的行数
Dim rng As Range
Dim r as long
Set rng = ActiveSheet.UsedRange
r= rng.Rows.Count
End Sub
[方法二]
Sub 计算行数()  '计算工作表中已使用单元格的行数
Dim r as long
r = Sheets(1).[a65536].End(xlUp).Row
End Sub
[程序说明]但此方法只能以一列为基础取行数,当另一列行数比该列行数多时,不能反映已使用的行数。
比较后认为,采用方法一较通用。
类似地,取列数方法相同。

******************************************************

程序3(对列表区域数据的操作—排序)
[程序功能] 对一列中所选择的数据进行排序,选择列表中选区的任一单元格后,消息对话框显示出该单元格数值在选区中的排序位置。
[程序]
Option Explicit ‘进行变量声明
Dim MyCell As Range
Dim r As Integer
Dim MyRange As Range
Dim Ans

Sub rankalist()
  Dim m As Integer
  Set MyRange = Selection
 
  On Error Resume Next

  m = Selection.Count
  MsgBox "Selection has " & m & " cells.", vbInformation, "Selection Count"

  Call rankprocess  ‘调用子过程
 
  While Ans = vbYes
    Call rankprocess
  Wend
 
  While Ans = vbNo
    Exit Sub
  Wend
End Sub

Sub rankprocess()
  Set MyCell = Application.InputBox(prompt:="Please select a cell:", Title:="Cell", Type:=8) ‘用输入框返回一个单元格对象给MyCell对象变量
 
  If Union(MyCell, MyRange).Address = MyRange.Address Then  ‘判断单元格是否在选区内
    r = 1 + MyRange.Cells.Count - Application.WorksheetFunction.rank(MyCell.Value, MyRange, 0) ‘使用Excel的rank函数进行排序
    Ans = MsgBox("  the present cell is ranked " & r & " in the list " & vbNewLine & "Continue?", vbYesNo) ‘显示排序结果并询问是否继续查看其它单元格排序,还是退出
  Else
    MsgBox "Please select a cell in selection."
  End If
End Sub

文档示例见UploadFiles/2006-6/66329144.rar

*******************************************************

程序4(对列表区域数据的操作—排序)
[程序功能] 在指定列中寻找所包含的字符串,并删除包含这些字符串的行。按对话框提示输入。
[情形一] 字符串必须是单元格中的全部字符
Sub 删除行_依全部字符()
    Dim MyRange As Range, DelRange As Range, C As Range
    Dim MatchString As String, SearchColumn As String, ActiveColumn As String
    Dim FirstAddress As String, NullCheck As String
    Dim AC
    '取活动列号
    AC = Split(ActiveCell.EntireColumn.Address(, False), ":")
    ActiveColumn = AC(0)
    SearchColumn = InputBox("输入要查找的列号-按取消按钮退出", "删除行", ActiveColumn)
    On Error Resume Next
    Set MyRange = Columns(SearchColumn)
    On Error GoTo 0
    '若单元格无效则退出
    If MyRange Is Nothing Then Exit Sub
    MatchString = Application.InputBox("输入要查找的完整的字符串", "删除行", ActiveCell.Value)
    If MatchString = "" Then
        NullCheck = InputBox("Do you really want to delete rows with empty cells?" & vbNewLine & vbNewLine & _
                             "Type Yes to do so, else code will exit", "Caution", "No")
        If NullCheck <> "Yes" Then Exit Sub
    End If
    Application.ScreenUpdating = False
    Set C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlWhole) '要求整个字符串匹配
    If Not C Is Nothing Then
        Set DelRange = C
        FirstAddress = C.Address
        Do
            Set C = MyRange.FindNext(C)
            Set DelRange = Union(DelRange, C)
        Loop While FirstAddress <> C.Address
    End If
    '如果找到匹配的数据则删除该行
    If Not DelRange Is Nothing Then DelRange.EntireRow.Delete
    Application.ScreenUpdating = True
End Sub

[情形二] 字符串可仅为单元格中的部分字符
Sub 删除行_依部分字符()
    Dim MyRange As Range, DelRange As Range, C As Range
    Dim MatchString As String, SearchColumn As String, ActiveColumn As String
    Dim FirstAddress As String, NullCheck As String
    Dim AC
    '取活动列号
    AC = Split(ActiveCell.EntireColumn.Address(, False), ":")
    ActiveColumn = AC(0)
    SearchColumn = InputBox("输入要查找的列号-按取消按钮退出", "删除行", ActiveColumn)
    On Error Resume Next
    Set MyRange = Columns(SearchColumn)
    On Error GoTo 0
    '若单元格无效则退出
    If MyRange Is Nothing Then Exit Sub
    MatchString = Application.InputBox("输入要查找的部分字符串", "删除行", ActiveCell.Value)
    If MatchString = "" Then
        NullCheck = InputBox("Do you really want to delete rows with empty cells?" & vbNewLine & vbNewLine & _
                             "Type Yes to do so, else code will exit", "Caution", "No")
        If NullCheck <> "Yes" Then Exit Sub
    End If
    Application.ScreenUpdating = False
    Set C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlPart)
    If Not C Is Nothing Then
        Set DelRange = C
        FirstAddress = C.Address
        Do
            Set C = MyRange.FindNext(C)
            Set DelRange = Union(DelRange, C)
        Loop While FirstAddress <> C.Address
    End If
    '如果找到匹配的数据则删除该行
    If Not DelRange Is Nothing Then DelRange.EntireRow.Delete
    Application.ScreenUpdating = True
End Sub

[程序说明]
1、本程序根据网友程序略作改动。
2、运行程序后,可根据对话框提示在工作表中直接选择(InputBox函数的功能)。

文档示例见UploadFiles/2006-6/66356445.rar

************************************************************

程序5(图表操作—三维饼图)
[程序功能] 创建三维饼图
[程序] 建立工作表数据并转换成三维饼图
Sub AddChart()
  Dim colCharts As Object
  Const xlDataLabelsShowPercent = 3  ‘定义缺省常量,显示图形上的百分比

‘打开Excel,新建一个工作簿和工作表
  Set objExcel = CreateObject("Excel.Application")
  objExcel.Visible = True
  Set objWorkbook = objExcel.Workbooks.Add()
  Set objWorksheet = objWorkbook.Worksheets(1)

‘在工作表中输入数据
  objWorksheet.Cells(1, 1) = "Operating System"
  objWorksheet.Cells(2, 1) = "Windows Server 2003"
  objWorksheet.Cells(3, 1) = "Windows XP"
  objWorksheet.Cells(4, 1) = "Windows 2000"
  objWorksheet.Cells(5, 1) = "Windows NT 4.0"
  objWorksheet.Cells(6, 1) = "Other"

  objWorksheet.Cells(1, 2) = "Number of Computers"
  objWorksheet.Cells(2, 2) = 145
  objWorksheet.Cells(3, 2) = 487
  objWorksheet.Cells(4, 2) = 211
  objWorksheet.Cells(5, 2) = 41
  objWorksheet.Cells(6, 2) = 56

‘运用这些数据添加一个新图表
  Set objRange = objWorksheet.UsedRange
  objRange.Select

  Set colCharts = objExcel.Charts
  colCharts.Add

  Set objChart = colCharts(1)
  objChart.Activate

‘设置图表的参数
  objChart.ChartType = 70
  objChart.Elevation = 30
  objChart.Rotation = 80

  objChart.ApplyDataLabels xlDataLabelsShowPercent ‘显示在整体中所占百分比的标签

‘去掉绘图区域或图表区域
  objChart.PlotArea.Fill.Visible = False
  objChart.PlotArea.Border.LineStyle = -4142 

‘数据标签的大小、颜色、字体样式以及其它属性
  objChart.SeriesCollection(1).DataLabels.Font.Size = 14
  objChart.SeriesCollection(1).DataLabels.Font.ColorIndex = 2

  objChart.ChartArea.Fill.ForeColor.SchemeColor = 49
  objChart.ChartArea.Fill.BackColor.SchemeColor = 23
  objChart.ChartArea.Fill.TwoColorGradient 1, 1

  objChart.ChartTitle.Font.Size = 24
  objChart.ChartTitle.Font.ColorIndex = 2

  objChart.Legend.Shadow = True

End Sub
[程序说明]
1、饼图能很形象地表示各部分的百分比。
2、Excel可以创建很多种图表和图形,并且每一种类型都被指定了一个唯一的ChartType编号。
3、Elevation 属性设置图形的倾斜度。Rotation 属性让图形左右旋转。
4、去掉绘图区域或图表区域(即图表上的小框),只需引用相应的对象(PlotArea 或 ChartArea)。将 Fill.Visible 属性设置为 False。将 Border.LineStyle 属性设置为 -4142,这一常量表示“完全不要显示边框”。请注意,光设置 Visible 属性将达不到效果:如果您仅设置了 Visible 属性,则图表四周仍会有一个灰色边框。要除去这个灰色边框,还需设置 LineStyle 属性。

程序代码见UploadFiles/2006-6/66299865.rar
 

抱歉!评论已关闭.