源代码

'检查选定矩形块的开始和最后两列数据的核对关系
'把两列中“相同”的数据的背景颜色改成黄色。
'使用方法：选中需要比较的两列数据（用一个矩形块选中包含此两列数据，使此两列数据是此矩形行块的第一和最后一列），
'          执行此宏。
Sub subzCheckTwoColNumber()
  Dim HH1, HH2, LL1, LL2, i, j, k
  Dim oCell1, oCell2
  Dim Val1, Val2
  HH1 = Selection.Rows.Row                      '开始的行号
  HH2 = HH1 + Selection.Rows.Count - 1          '结束的行号
  LL1 = Selection.Columns.Column                '第一列的列号
  LL2 = LL1 + Selection.Columns.Count - 1       '最后列的列号
  If LL1 = LL2 Then Return
  For i = HH1 To HH2
    Set oCell1 = Cells(i, LL1)
    If IsNull(Ocell) Then
    
    Else
      Val1 = 0 + Val(oCell1.Value)
      For j = HH1 To HH2
        Set oCell2 = Cells(j, LL2)
        If IsNull(oCell2) Then
        
        Else
          Val2 = 0 + Val(oCell2.Value)
          If oCell2.Interior.ColorIndex <> 6 And Abs(Val1 - Val2) < 0.0005 Then
            oCell1.Interior.ColorIndex = 6
            oCell2.Interior.ColorIndex = 6
            j = HH2 + 1
          End If
        End If
      Next j
    End If
  Next i
End Sub

'取所有工作表名称
'20091016 刁星伍
'输入:无
'输出:所有工作表名称的列表,用回车符分开。
'返回数据后,可以复制到记事本后再复制回来即可显示列表。
Function getSheetList() As String
  Dim i As Integer
  For i = 1 To Sheets.Count
     getSheetList = getSheetList + Sheets(i).Name + Chr(9) + Chr(13) + Chr(10)
  Next
  getSheetList = Left(getSheetList, Len(getSheetList) - 3)
End Function
  

'计算企业代码的校验位，参见GB11714-89
'输入  sCode：前8位代码
'返回  sVcode：校验码
'刁星伍  2009-6-17
Function sVcode(sCode As String) As String
   Dim I As Integer, J As Integer, s1 As String, s2 As String
   Dim iC9 As Integer           '计算的校验码及中间
   Dim iCi As Integer
   Dim aW(8) As Integer                 '加权因子
   If Len(sCode) <> 8 Then
      sVcode = "本体代码不等于8位"
   Else
      aW(1) = 3: aW(2) = 7: aW(3) = 9: aW(4) = 10
      aW(5) = 5: aW(6) = 8: aW(7) = 4: aW(8) = 2
      iC9 = 0
            'iCi = Asc(s1) - 48     '字符－》数字
            
      For I = 1 To 8
        s1 = UCase(Mid(sCode, I, 1))       'Ci  当前位字符
        If s1 = "#" Then
            iCi = 36
        ElseIf s1 < "0" Then
            sVcode = "错误的字符"
            Exit Function
        ElseIf s1 <= "9" Then
            iCi = Asc(s1) - 48
        ElseIf s1 < "A" Then
            sVcode = "错误的字符"
            Exit Function
        ElseIf s1 <= "Z" Then
            iCi = Asc(s1) - 55
        Else
            sVcode = "错误的字符"
            Exit Function
        End If
        iC9 = iC9 + iCi * aW(I)     '取合计
      Next I
        iC9 = 11 - (iC9 Mod 11)
        If iC9 = 10 Then
            sVcode = "X"
        ElseIf iC9 = 11 Then
            sVcode = "0"
        Else
            sVcode = Chr(iC9 + 48)
        End If
   End If
End Function

'设置本工作表的相应数据到“打印”工作表的相应单元，并打印。
'用法：
'   1.在打印工作表中设置好相应的打印设置。
'   2.把需要填充的单元格中添加“批注”，并使批注的内容为需要填充单元格的列号。如：B
'   3.把需要的数据信息，填写在当前的工作表中。
'   4.光标定位到需要打印的行（可以单击此行的任意单元格）。
'   5.单击“打印当前行证件”按钮。
'   6.根据需要预览后输出还是直接输出，只需要修改本过程的倒数第3和第4行的信息（去掉或加上前边的单引号）。
'  刁星伍 2008-5-8
'设置打印信息
Private Sub CommandButton1_Click()
    Dim s1 As String, s2 As String, s0 As String
    Dim L1 As Integer, L2 As Integer, H1 As Integer, H2 As Integer
    Dim i As Integer, j As Integer
    Dim Ocell As Object, oCell0 As Object
    Dim H0 As Integer
    s0 = ActiveSheet.Name
'    If s0 <> "数据库" Then
'      MsgBox "请到“数据库”工作表中执行本宏"
'      Exit Sub
'    End If
    H0 = ActiveCell.Row                         '当前行
    s1 = Sheets("打印").PageSetup.PrintArea     '打印工作表中的打印区域
    If Trim(s1) = "" Then
        MsgBox "“打印”工作表中没有定义打印区域，请定义好打印区域后再执行本功能。"
        Exit Sub
    End If
    H1 = Range(s1).Row                  '打印区域开始的行
    L1 = Range(s1).Column               '打印区域开始的列
    H2 = H1 + Range(s1).Rows.Count - 1 '打印区域结束的行
    L2 = L1 + Range(s1).Columns.Count - 1 '打印区域结束的列
    On Error Resume Next
    For i = L1 To L2
        '此循环设置一列数据
        For j = H1 To H2
            '此循环设置一行数据
            Set Ocell = Sheets("打印").Cells(j, i)
            If Ocell.Comment.Text = "" Then
            Else
                Set oCell0 = Sheets(s0).Range(Trim(Replace(Ocell.Comment.Text, Chr(10), "")) & H0)
                Set Ocell = Sheets("打印").Cells(j, i)
                Ocell.Value = oCell0.Value
            End If
        Next j
    Next i
    Sheets("打印").PrintPreview        '打印预览 ,如果直接打印输出，则屏蔽此行，开放下一行即可
    'Sheets("打印").PrintOut           '直接打印输出,如果预览后输出，则屏蔽此行，开放上一行即可
    Cells(H0 + 1, 1).Activate          '自动转动下一行
End Sub

下载本实例后自己修改即可

sub 遍例选定单元格1()
    Dim oCell As Object
    Dim n
    On Error Resume Next
    For Each oCell In Selection
       '处理单元格
       'oCell.value=
    Next oCell
    On Error Goto 0
End Sub

Sub 遍例选定单元格2()
    Dim oCell As Object
    Dim i As Integer, j As Integer
    Dim L1 As Integer, L2 As Integer, H1 As Integer, H2 As Integer
    L1 = Selection.Columns.Column       '第一个选定单元格(左上角)的列号
    H1 = Selection.Rows.Row             '第一个选定单元格(左上角)的行号
    H2 = H1 - 1 + Selection.Rows.Count  'Selection.Rows.Count 选定的单元格行数
    L2 = L1 - 1 + Selection.Columns.Count 'Selection.Columns.Count 选定的单元格的列数
    For i = H1 To H2
        For j = L1 To L2
            Set oCell = Cells(i, j)         '待处理的单元格
            oCell.Value = Chr(64 + j) & i   '处理单元格
       Next j
    Next i
End Sub

'如 0.00 或 0换成空白 ;
'
Sub Clear_0()
Dim oCell As Object
Dim val1 As Variant
Dim str1 As String, str2 As String, str3 As String
   For Each oCell In Selection
      On Error GoTo err1		'有错则下一单元格
      val1 = oCell.Value
      If IsNumeric(val1) Then		'检查是否是数字
        If Abs(val1) < 0.005 Then	'绝对值<0.005则清零
          str1 = ""
          oCell.Value = str1
        End If
      End If
err1:
   Next oCell
End Sub
        

'
'把选中单元各中的左边空格的数量减半
'如 "    1234"换成"  1234"
'
Sub Modi_Space()
Dim oCell As Object
Dim val1 As Variant
Dim str1 As String, str2 As String, str3 As String
   For Each oCell In Selection
      On Error GoTo err1
      val1 = oCell.Value
      str1 = val1
      str2 = LTrim(str1)		'取消左边的所有空格
      str3 = Space(Len(str1) / 2 - Len(str2) / 2) + str2	'去掉左边一半的空格
      oCell.Value = str3
err1:
   Next oCell
End Sub

'把选择的单元的格式从字符转换为数字
Sub sub1()
 Dim oCell As Object
 On Error Resume Next
 For Each oCell In Selection
    If "L" & oCell.Value <> "L" Then
        oCell.Value = oCell.Value + 0
    End If
 Next
End Sub
        

'改编于《施工企业财务核算系统》。
Function dxje(ByVal curJinE As Currency) 
  Dim pdxzf, pdxdw, pjezc, pdwwz, pjewz 
  Dim s1 As String 
  If curJinE = 0 Then 
     dxje = "" 
  Else
    pdxzf = "零壹贰叁肆伍陆柒捌玖" 
    pdxdw = "仟佰拾亿仟佰拾万仟佰拾元角分" 
    pjedx = IIf(curJinE < 0, "(红字)", "") 
    pjesz = Abs(curJinE) 
    pjezc = Format(pjesz * 100, "#0") 
    pjezc = Space(14 - Len(pjezc)) + pjezc 
    pdwwz = 0 
    For pjewz = 1 To Len(pjezc) 
        s1 = Mid(pjezc, pjewz, 1) 
        If s1 <> " " Then 
            pdwwz = pdwwz + 1 
            If s1 = "0" Then 
                If pjewz = 4 Then 
                    pjedx = pjedx + "亿" 
                ElseIf pjewz = 8 And Right(pjedx, 1) <> "亿" Then 
                    pjedx = pjedx + "万" 
                ElseIf pjewz = 12 Then 
                    pjedx = pjedx + "元" 
                ElseIf pjewz <> 14 And Mid(pjezc, pjewz + 1, 1) <> "0" Then  
                    pjedx = pjedx + "零" 
                End If 
            Else
                pjedx = pjedx + Mid(pdxzf, Val(Mid(pjezc, pjewz, 1) + 1), 1) 
                pjedx = pjedx + Mid(pdxdw, pjewz, 1) 
            End If 
        End If 
    Next
    pjedx = Trim(LTrim(pjedx + IIf(Right(pjedx, 1) = "分", "", "整"))) 
    dxje = pjedx 
  End If 
End Function
        

'把选中单元格的连接修改成当前的文本内容
'用Excel的自动编号功能生成网上的系列连接，后保存成网页html文件，最后使用下载工具下载。
Sub 修改单元格的超链接()
 Dim oCell As Object
 Dim val1 As Variant
 Dim str1 As String, str2 As String, str3 As String
   For Each oCell In Selection
      On Error GoTo err1
      val1 = oCell.Value
      ActiveSheet.Hyperlinks.Add Anchor:=oCell, Address:=val1
err1:
   Next oCell
End Sub