VBA程序集

最新推荐文章于 2024-10-04 17:52:38 发布

ZOU_SEAFARER

最新推荐文章于 2024-10-04 17:52:38 发布

阅读量1.5k

点赞数

分类专栏： VBA 文章标签： vba integer 文档 textbox 工作 excel

VBA 专栏收录该内容

67 篇文章 21 订阅

订阅专栏

VBA程序集
(第7辑)
下面为第7辑VBA程序集的内容，包含程序说明和代码，以及示例文档。

程序27(文本框-限制文本框中输入的内容)
本程序提供了限制用户在文本框中所能够输入的内容的示例。在示例中，您只能在文本框中输入数字，在第一个字符的位置输入“-”号，以及输入中文字符。当然，您可以修改Case语句中的第一个Case语句，来设定允许输入的字符类型。
[程序代码]
‘******************************************************
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Select Case KeyAscii
    Case Asc("0") To Asc("9")
    Case Asc("-")
        If Instr(1,Me.TextBox1.Text,"-") > 0 Or Me.TextBox1.SelStart > 0 Then
            KeyAscii = 0
        End If
    Case Asc(".")
        If InStr(1, Me.TextBox1.Text, ".") > 0 Then
            KeyAscii = 0
        End If
    Case Else
        KeyAscii = 0
End Select
End Sub
‘******************************************************
[示例文档见 (程序27)文本框输入测试.xls。UploadFiles/2006-8/89335571.rar

程序28(列出所有的颜色和索引值)
本程序运行后将新建一个工作簿，并在该工作簿的A列中列出Excel所支持的56种颜色和对应的颜色索引值。
[程序代码]
‘******************************************************
Sub TestColor()
Dim objExcel As Application
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
objExcel.Workbooks.Add

Dim i As Integer
For i = 1 To 56
objExcel.Cells(i, 1).Value = i
objExcel.Cells(i, 1).Interior.ColorIndex = i
Next
End Sub
‘******************************************************
示例文档见 (程序28)测试颜色索引号.xls。UploadFiles/2006-8/89223153.rar

程序29(合并单元格中的内容)
本程序将工作簿中所选区域内同一行的单元格内容合并至第一列的单元格。即合并一行中被选择的单元格内容至行首单元格中，或者合并被选择区域的每一行单元格的内容到行首单元格中。
在运行程序前，您必须先选择要合并的单元格所在的行或单元格区域。
[程序代码]
‘******************************************************
Sub 合并单元格内容()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
Dim iRows As Long, iCols As Long, mRow As Long, ir As Long, ic As Long
Dim lastcell As Range, newcell, trimmed
iRows = Selection.Rows.Count
iCols = Selection.Columns.Count
Set lastcell = Cells.SpecialCells(xlCellTypeLastCell)
mRow = lastcell.Row
If mRow < iRows Then iRows = mRow
For ir = 1 To iRows
    newcell = Trim(Selection.Item(ir, 1).Value)
    For ic = 2 To iCols
      trimmed = Trim(Selection.Item(ir, ic).Value)
      If Len(trimmed) <> 0 Then newcell = newcell & " " & trimmed
      Selection.Item(ir, ic) = ""
    Next ic
    Selection.Item(ir, 1).Value = newcell
Next ir
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
‘******************************************************
示例文档见 (程序29)合并单元格内容.xls。UploadFiles/2006-8/89304397.rar

程序30(分离单元格中的内容)
本程序将工作簿中所选单元格的内容分解到相邻单元格中。在所要分解的单元格中的内容以空格为标志，例如单元格中的内容若为“A Dog”，则会分解为“A”和“Dog”。注意，所要分解的单元格中的相邻单元格必须为空。您可以将本程序稍作修改后，应用于分离地址。
[程序代码]
‘******************************************************
Sub 分离单元格()
Dim iRows As Long, mRow As Long, ir As Long
Dim lastcell As Range, checkx
Dim iAnswer As Boolean
Dim L As Long, im As Long
Application.ScreenUpdating = False
On Error Resume Next
iRows = Selection.Rows.Count
Set lastcell = Cells.SpecialCells(xlLastCell)
mRow = lastcell.Row
If mRow < iRows Then iRows = mRow
For ir = 1 To iRows
       If Len(Trim(Selection.Item(ir, 1).Offset(0, 1))) <> 0 Then
          iAnswer = MsgBox("Found non-blank in adjacent column -- " _
             & Selection.Item(ir, 1).Offset(0, 1) & " -- in " & _
             Selection.Item(ir, 1).Offset(0, 1).AddressLocal(0, 0) & _
             Chr(10) & "Press OK to process those than can be split", _
          vbOKCancel)
          If iAnswer = vbOK Then GoTo DoAnyWay
          GoTo terminated
       End If
Next ir
DoAnyWay:
For ir = 1 To iRows
       If Len(Trim(Selection.Item(ir, 1).Offset(0, 1))) <> 0 Then GoTo nextrow
       checkx = Trim(Selection.Item(ir, 1))
       L = Len(Trim(Selection.Item(ir, 1)))
       If L < 3 Then GoTo nextrow
       For im = 2 To L
          If Mid(checkx, im, 1) = " " Then
             Selection.Item(ir, 1) = Left(checkx, im - 1)
             Selection.Item(ir, 1).Offset(0, 1) = Trim(Mid(checkx, im + 1))
             GoTo nextrow
          End If
       Next im
nextrow:
Next ir
terminated:
   Application.ScreenUpdating = True
End Sub
‘******************************************************
示例文档见 (程序30)分离单元格中的内容UploadFiles/2006-8/89716164.rar

程序31(自动安装加载宏)
本程序运用VBA安装加载宏，例如，下面的程序代码运行后将安装“分析工具库”加载宏。当您运行程序后，会发现“分析工具库”已安装至您的Excel中。注意，应确保所要安装的加载宏已在“加载项”中。
[程序代码]
‘******************************************************
Sub 安装分析工具库()
   Dim oAddin As AddIn
   For Each oAddin In AddIns
      If oAddin.Name = "ANALYS32.XLL" Then
         oAddin.Installed = True
      End If
   Next
End Sub
‘******************************************************

程序32(在工作表中添加一个箭头)
本程序运行后将在工作表中添加一个箭头形状。您可以调整代码中的相应数值，以改变箭头的形状和大小。
[程序代码]
‘******************************************************
Sub AddArrow()
    Dim oShp As Shape

    '添加一个箭头形状对象
    Set oShp = ActiveSheet.Shapes.AddShape(msoShapeRightArrow, 10, 10, 100, 50)

    '设置箭尾占整个形状长度的百分比
    oShp.Adjustments(1) = 0.3
    '设置箭尾显示的宽度，即点整个宽度的百分比
oShp.Adjustments(2) = 0.4
End Sub
‘******************************************************

程序33(提示用户所要进行的操作)
本程序的功能为在用户窗体中，您进行下一步操作之前前，为您对必须要进行操作的控件进行提示。本程序利用了控件的Tag属性。
示例中，提示用户在用户窗体中必须要输入的文本框。当然，您可以在程序设计时，利用这一特性限制用户必须进行的某些操作后才能继续后续操作。
[程序代码]
‘******************************************************
**********以下代码输入在ThisWorkbook模块中**********
Private Sub Workbook_Open()
UserForm1.Show
End Sub
**********以下代码在UserForm1窗体模块中**************
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Call CheckEmptyTextbox
End Sub
**********以下代码在标准模块中****************************
Sub CheckEmptyTextbox()
Dim ctl As Control
For Each ctl In UserForm1.Controls
    If TypeName(ctl) = "TextBox" Then
      If ctl.Tag = "Required" Then
        If ctl.Text = "" Then
          MsgBox "请在" & ctl.Name & "中输入相应的内容."
        End If
      End If
    End If
Next ctl
End Sub
‘******************************************************
示例文档见 (程序33)提示用户进行输入.xls。UploadFiles/2006-8/89414507.rar

程序33(根据指定列中的数据隐藏相应的行)
本程序将根据指定列中的数据，隐藏包含该数据的行。对于本程序，您可以改变程序中的指定列或指定的条件，从而实现满足条件的筛选。譬如，您可能想筛选出还未发工资的人员，您可以将工资列中不为零的行全部隐藏，只显示该列中值为零的行。
[程序代码]
‘******************************************************
Sub 根据列值隐藏行()
Dim lngCol As Long
Dim strCondition As String
Dim ws As Worksheet
Dim r As Range

'设置想要隐藏的值所在的列
lngCol = 3
'设置查找的条件
strCondition = "<> 0"
'设置在当前工作表中进行操作
Set ws = ActiveSheet

With ws.Rows(1)
    .AutoFilter '打开自动筛选
    .AutoFilter field:=lngCol, Criteria1:=strCondition '筛选条件
    '存放单元格区域
    Set r = Application.Intersect(ws.Cells.SpecialCells(xlCellTypeVisible), _
    ws.UsedRange.Offset(1, 0), ws.UsedRange)
    .AutoFilter '关闭自动筛选
End With
'隐藏所满足条件的单元格区域所在行
r.EntireRow.Hidden = True
End Sub
‘******************************************************
示例文档见 (程序34)根据指定列的值隐藏所在行.xls。UploadFiles/2006-8/89209695.rar