vb自定义函数

自定义函数功能

自定义函数取值范围如何设定
my:
我现在在excel中用加载宏建立一个自己用的函数，不过我碰到一个问题，我要输入一个范围的参数，但不知道怎么样赋给函数。
function aa(color as integer，arg1 as string) as double
…………
for each c in range(arg1).cells
…………
next
…………
end function
我现在要把选择的范围如A1:A5、A1:E1、A1:E5这三中情况中的一种赋值给arg1,我用string好像不行，不知道该如何设置该参数的值
相当于VLOOKUP吧，查询某一值第num次出现的值
my:
作用说明：
相当于VLOOKUP吧，查询某一值第num次出现的值
参数说明：
Value1：查询引用的数值
Range1：查询区域
num：指定查询第几次出现
Col：返回值,相对引用区域,相对引用列的右数第Col列


[Copy to clipboard]CODE:
Function MyFind(Value1, ByVal Range1 As Range, ByVal num As Integer, ByVal Col As Integer)
If Value1 = "" Then
返回指定列数的列标
my:
返回指定列数的列标
'pureNum为1-256之间的整数


[Copy to clipboard]CODE:
Public Function NumToChr(PureNum As Integer) As String
If PureNum Mod 26 = 0 Then
NumToChr = VBA.IIf(PureNum \ 26 = 1, "", VBA.Chr(PureNum \ 26 + 63)) & "Z"
Else
If PureNum <= 256 Then
N
用指定字符替换某字符
my:
Public Function ReplaceIt(OriginalStr As String, SearchStr As String, ToBeReplaced As String) As String
Dim FoundPos As Integer
Do While VBA.InStr(1, OriginalStr, SearchStr) <> 0
FoundPos = VBA.InStr(1, OriginalStr, SearchStr)

从右边开始查找指定字符在字符串中的位置
my:
从右边开始查找指定字符在字符串中的位置
Public Function MyInStrRev(MainStr As String, SubStr As String) As Integer
Dim Counter As Integer
Dim Success As Boolean
If VBA.Len(MainStr) < VBA.Len(SubStr) Then
MyInStrRev = 0
Else
For Counter = V
将20040510数字格式，转换为2004－5－10的日期格式的函数
my:
将20040510数字格式，转换为2004－5－10的日期格式的函数

Public Function 日期格式(rd1)
Dim day1 As Date
Dim rdy1 As String
Dim nn1, yn1, dn1 As Integer
rdy1 = Trim(rd1)
If Len(rdy1) <> 8 Then
日期格式 = "日期位数不对"
Exit Function
End If

On Error G
工龄计算：
my:
工龄计算：
Function Elapsed(StartDate As Date, EndDate As Date, ReturnType As Integer)
Dim StartYear As Integer '定义变量用以参数中开始日期的计算
Dim StartMonth As Integer
Dim StartDay As Integer
Dim EndYear As Integer '定义变量用以参数中结束日期的计算
Dim EndMonth As Integer
Dim EndDay
计算日期差，除去星期六、星期日的自定义函数
my:
Function daydif(x As Range, y As Range)

Dim date1, date2 As Date
date1 = x
date2 = y

dif = 0
Do
If (date1 >= date2) Then

Exit Do
End If

date1 = date1 + 1
t1 = Weekday(date1)
If (t1 < 7 And t1
這是一個將英文字反轉的自定函數
my:
Function TextReverse(sSource As String) As String
Dim iCounter As Integer
Dim sText As String
For iCounter = Len(sSource) To 1 Step -1
sText = sText & Mid(sSource, iCounter, 1)
Next
TextReverse = sText
End Function
关于个人所得税的
my:
具体函数如下
'q为应纳税所得额 ，w为扣除额，可自定义，如800

'应用：如a1为应纳税所得额，直接在单元格输入“=sds(a1,800)"，也可以是“=sds(a1,b1))"
'如果扣除额不是800，可自己改数字，也可以是单元格

Public Function sds(q, w)

je = q - w
If q < w Then
'msgbox("应纳税所得额必须大于或等于扣除额!")
sds = 0
ElseIf je <= 500 Then
sds = je *
一个能计算是否有重复单元的函数
my:
Function IsRepeate(c As Range) As Boolean

Dim cell As Range
Dim SumC As Integer
Dim CountBlank As Integer
SumC = 0: CountBlank = 0
For Each cell In c
If VBA.IsEmpty(cell) Then
CountBlank = CountBlank + 1
Else
SumC = SumC + 1 /
试编写数字金额转中文大写的函数
my:
Function DaXie(ByVal Num) ' 人民币中文大写函数
Application.Volatile True
Place = "分角元拾佰仟万拾佰仟亿拾佰仟万"
Dn = "壹贰叁肆伍陆柒捌玖"
D1 = "整零元零零零万零零零亿零零零万"
Num = Format(Abs(Num), "###0.00") * 100
If Num > 999999999999999# Then: DaXie = "数字超出转换范围!!
人民币大小写转换函数
my:
Function NtoC(ByVal n) As String 'n as Currency
Const cNum As String = "零壹贰叁肆伍陆柒捌玖-万仟佰拾亿仟佰拾万仟佰拾元角分"
Const cCha As String = "零仟零佰零拾零零零零零亿零万零元亿万零角零分零整-零零零零零亿万元亿零整整"
Dim sNum As String
Dim i As Long

If (n <> 0) And (Abs(n) < 10000000000000#)
获取区域颜色值自定义函数:
my:
Function ColorID(ReColor As Range) As Integer
Application.Volatile
ColorID = ReColor.Interior.ColorIndex
End Function
获取活动工作表名的自定义函数：
my:
获取活动工作表名的自定义函数：
Public Function sh_name() as string
sh_name =
End Function
显示在“插入函数”对话框的“或选择类别”下拉列表中
my:
本示例将用户定义的宏“TestMacro”添加到名为“My Custom Category”的自定义类别中。运行本示例后，可以看到包含“TestMacro”用户定义函数的“My Custom Category”显示在“插入函数”对话框的“或选择类别”下拉列表中。

Function TestMacro()
MsgBox
End Function

Sub AddUDFToCustomCategory()
Application.MacroOp
复合函数
my:
复合函数：
The StatFunction Function
Function STATFUNCTION(rng, op)
Select Case UCase(op

)
Case "SUM"
STATFUNCTION = Application.Sum(rng)
Case "AVERAGE"
STATFUNCTION = Application.Average(rng)
Case "MEDIAN
对工作表的第一列进行各种查询
my:
如果频繁对一些数据区域进行各种操作，应该为该区域编写专门的过程，然后定义各种参数来输入返回你想要的东西。

例子：
Function Seek_DataRow(sh as string,entryType As Integer, Optional Condition As String) As Long
'对工作表的第一列进行各种查询
dim myrange as range

set Set myRange = Worksheets(sh).Range("a2:a65536")

序数词转换函数
my:
Function Ordinal(ByRef lngCardinal As Long) As String
' Chris Rae's VBA Code Archive - /vba
' Code by Will Rickards, 15/01/2004
Dim lngTemp1 As Long
Dim lngTemp2 As Long

' last two digits
lngTemp2 = lngCardinal Mod 10
获取最后一行行数的自定义函数：
my:
Function Myrange()
Myrange = Worksheets("数据表").[B65536].End(xlUp).Row
End Function

Function Myrange() 為自訂函數,自訂函數也可以直接在工作表使用
例如在A1打入 =Myrange() 將會傳回"数据表"中B欄的最後一列的行數

Myrange = Worksheets("数据表").[B65536].End(xlUp).Row
取得"数据表"中B欄的最後一列的行數

判断是否连接在线的函数
my:
判断是否连接在线的函数

Public Declare Function InternetGetConnectedState _
Lib "wininet.dll" (lpdwFlags As Long, _
ByVal dwReserved As Long) As Boolean

Function IsConnected() As Boolean
Dim Stat As Long
IsConnected = (InternetGetConnectedState(
查找一字符串(withinstr)在另一字符串中
my:
函数名称：Findstr()
'作 用：查找一字符串(withinstr)在另一字符串中(findstr1)中某一次(startnum)出现时的位置，返回零表示没找到。
'使用方法：如Findstr("IloveVBA VeryMuch,VBAisMylove","VBA",1),返回结果为6；Findstr("IloveVBAVeryMuch,VBAisMylove","VBA",2),返回结果为18。

Public Function findstr(ByVal findstr1 A
从工作表第一行的标题文字以数字形式返回所在列号
my:
从工作表第一行的标题文字以数字形式返回所在列号

'例如： 姓名col = 从列标题名称获取列号数("人事档案", "姓名")
' 如果是"人事档案"为当前工作表，上式可写成：
' 姓名col = 从列标题名称获取列号数("", "姓名")

Private Function 从列标题名称获取列号数(thisSheetName$, thisTitle$) As Long

'约定标题在第一列，Ａ１起，无间断

Dim c As Integer

多工作表有条件求和
my:
多工作表有条件求和


试下这个自定义函数

Function SumIfAllSheets(rang As Range, Criteria As Variant, sum_range As Range)
Dim wSheet As Worksheet
Dim vSum
On Error Resume Next

For Each wSheet In ActiveWorkbook.Worksheets
With wSheet
Set rang

= .Ran
有的时候需要返回多个数值，那就是用返回数组吧
my:
自定义函数通常都是返回一个数值，可有的时候需要返回多个数值，那就是用返回数组吧！举例如下：大于0的数值n,要同时返回它的倒数、平方数和平方根数。代码如下： public function sx(n as single)as single
dim ars(3)
if n<0 then
msgbox "数据必须不小于0，请重新输入数据！"
exit function

Excel自定义函数返回一组字符串
my:
Excel自定义函数，通常返回一个数值或一个字符串（放置于一个单元格中的字符串），但有时需要返回一组字符串，放置于几个单元格中。例如，经常需要输入表头：商品名称、单价、数量和金额。其代码如下：
Public Function bth() as variant
bth=Array("商品名称","单价","数量","金额")
End Function
使用中，先选定A1:D1单元格区域，输入公式：＝bth() ，按Ctrl+Shift+Enter组
也来个返回指定列数的列标号自定义函数
my:
public function nch(n as integer)as string
if n<1 or n>256 then
msgbox "Excel的列数范围为：1－256，请重新输入！"
exit function
end if
nch=VBA.iff(n<27,chr(n+64),chr( n\26+64) &chr(n mod 26 +64))
end function
其中:"n\26"为26被n整除，相当于被26除
返回 Column 英文字
my:
返回 Column 英文字


Function ColIntToLetter(intCol As Integer) as string
'
Dim intPart As Integer
Dim intRemainder As Integer

If intCol > 255 Or intCol <= 0 Then
MsgBox ("The Wrong Column Number: " & CStr(intCol))
Exit Function
End If

intPart =
查找指定列名的列数
my:
查找指定列名的列数
Function FindColumnNumber(strTmp As String, strsheet As String) as integer
' strSheet is the name of the sheet
' strTmp is the name of this column
Dim Tmp As String

Sheets(strsheet).Select
strTmp = LCase(strTmp)
FindColumnNumber = 0

For j
文字格式的时间(分:秒)转化为数字格式(秒)
my:
文字格式的时间(分:秒)转化为数字格式(秒)


1:34
变为94秒

Function TxtSecondToNumber(strTxt As String)
' The format of strTxt is mm:ss.??
'
Dim iFirst As Integer

strTxt = Trim(strTxt)

iFirst = InStr(1, strTxt, ":")
If iFirst > 0 Then
TxtSecondToNumber = Val(Left
将"hh:mm:ss"格式的时分秒数转换成秒数
my:
将"hh:mm:ss"格式的时分秒数转换成秒数


模仿Maljx188楼长，来个将"hh:mm:ss"格式的时分秒数，转化为秒数。
例如，＝tom ( "23:11:15.2")，运算结果为：83475.2秒；
＝tom ("0:1:15.2")，运算结果为：75.2秒
public function tom (str1 as string) as single
Dim f1 as integer, f2 as integer
Dim tom1 as single,tom2 as sin
试编写金额中文大写转数字函数
my:
' 试编写金额中文大写转数字函数
' SamSea 18/10/2004

Function SuZi

(A As String) ' 人民币中文大写转数字函数
Application.Volatile True
Hsf = "分角元拾佰仟万 亿"
Hs = "零壹贰叁肆伍陆柒捌玖 "
JH = 1
A = Replace(A, "整", "")
A = Replace(A, "亿", ")亿")
A = Replace(A, "万", ")万")
身份证号码侦测 自定义函数
my:
身份证号码侦测 自定义函数


=xfz(身份证号，性别)
*****************************************

Public Function xfz(sid, xb) ' As Currency
'1、身份证不满15位，2、性别与身份证不符，3、出生月份出错(不在1-12)
'4、出生日期出错(不在1-31范围内)，5、18位校验位出错，6、18位身份证年份出借
On Error Resume Next
Dim s1, s2, jym, x
If xb = 1
显示公式的函数
my:
Function xsgs(Vcell As Range, TrueOrFalse As String)
If Left(Vcell.FormulaR1C1, 1) = "=" Then
If TrueOrFalse = "True" Then xsgs = Vcell.Formula Else: xsgs = Vcell.FormulaR1C1
Else
xsgs = "nothing"
End If
End Function


用途：假
为财务人员理帐查找用的
my:
下午编写的，是为财务人员理帐查找用的。
作用是execl 表中，比如
留下来的往来帐比较多的时候用的：
searchit（ 金额, 构对 参数[比如是款项性质，对方单位，某某人的，可以多项，自己增加]）
返回的是查找到的行次。
写的比较粗陋，呵呵，只是的启发，对自己的，希望也是大家的。

Function searchit(need_search As Range, overit As Range, p_1 As Range, p_2 As Range, p_3 As Range, p_4 As
数值转换为字符地址
my:
数值转换为字符地址
Public Function NtoC(Numbers As Integer) As String
Dim S As String, E As String
If Numbers <= 26 Then
NtoC = Chr$(Numbers + 64)
Else
S = Chr$(Int((Numbers - 1) / 26) + 64)
If Numbers Mod 26 = 0 Then

字符地址转换为数值
my:
再来一个对应的
'字符地址转换为数值
Public Function CtoN(Strings As String) As Integer
Dim Sl As Long, S1 As String, S2 As String
Strings = UCase(Strings)
Sl = Len(Strings)
If Sl = 0 Then
CtoN = 0
ElseIf Sl = 1 Then
CtoN = Asc(Strin
VB中用的，虽然VBA中也有一个Application.Wait功能
my:
这个函数本是在VB中用的，虽然VBA中也有一个Application.Wait功能，但我也帖出


'等待时间（以秒计算）
Public Sub WaitTime(ByVal SpecSecond As Integer)
Dim S1 As Date, S2 As Date, S As Long
If SpecSecond <= 0 And SpecSecond > 60 Then Exit Sub
S = 0
S1 = Time()
Do

得到字符串实际的长度（以单字节记）
my:
得到字符串实际的长度（以单字节记）
以下是一个获得字符串实际长度的函数，主要是解决LENB与LEN的部分不足，我在我的一些软件开发中基本上都用它，效率也不错
Function LenTrue(SourceStr)
Dim L, S, LenIs, GetStr
S = 0: L = 0
Do

S = S + 1
'是双字节，跳到下一个字符
GetStr =
也做个个人所得税
my:
也做个个人所得税

Function tax(aa As Range)
i = aa - 800
Select Case i
Case Is > 5000
tax = i * 0.2 - 375
Case Is > 2000
tax = i * 0.15 - 125
Case Is > 500
tax = i * 0.1 - 25
Case Is > 0
tax = i * 0.05

18位身份证最后一位有效性验证
my:
'18位身份证最后一位有效性验证
Function isTrue(bCode As String) As String
Dim wi(1 To 17) As Integer
Dim ai(1 To 11) As String
wi(1) = 7
wi(2) = 9
wi(3) = 10
wi(4) = 5
wi(5) = 8
wi(6) = 4
wi(7) = 2
wi(8) = 1
wi(9) = 6
wi(10) = 3
wi(11) = 7
计算符合maturity condition的拆解金额
my:
计算符合maturity condition的拆解金额


主管让中午吃饭前把过去两个月里的拆解合同符合到期条件的金额换算成人民币后加总，一气之下写的（资本主义灭绝人性！）。有两长表，若干个name。希望对那些在银行的同学有用。。


Public Function LiabToHo(dReportDate As Date, dbUSD2CNY As Double, _ dbHKD2CNY As Double) As Double

Dim EntryNum As Integer

相当于多个vlookup函数相加，
my:
Function vlookupmore(lookup_value, delimiter, data_type, table_array, col_index_num)
With Application.Caller
If Not .Comment Is Nothing Then .Comment.Delete
kmarr = split(lookup_value, delimiter)
For Each perkm In kmarr

判断表是否存在的函数
my:
判断表是否存在的函数：
Public Fnction IsSheetExist(wb as WorkBook,sht as String) as boolean
on error goto ErrISE
dim s as string

s=wb.worksheets(sht).name
IsSheetExist=True
ErrISE:
IsSheetExist=False
end function
我这个是角度转弧度的，以供大家参考
my:
我这个是角度转弧度的，以供大家参考


Public Const pi = 3.1415926535
Public Function hd(dfm As Single) As Double
Dim d As Integer
Dim f As Single
Dim m As Single

'分别取出输入度数的度、分、秒
d = Fix(dfm)
f = Fix((dfm - d) * 100)
m = ((dfm - d) * 100 - f)
If f >= 60 Or m >= 60 Then
比较相同的字符串
my:
比较相同的字符串

Function FindExistCount(rngSource As Range, rngTarget As Range) As Long
Dim lngCount As Long
Dim rg As Range
Dim rngFind As Range

For Each rg In rngTarget
Set rngFind = rngSource.Find(rg.Text)
If Not
對選定的陣列進行排序
my:
對選定的陣列進行排序

Sub SORTX()
Dim XX() As Variant
Dim Addres As Excel.Range
Dim Record As Long
Addre = ActiveWindow.RangeSelection.Address

With Range(Addre)
SRow = .Row '陣列起始列
CRow = .Rows.Count '陣列總列數
TRow = SRow
取得指定月份天數
my:
取得指定月份天數
Public Function MDay(Optional XDate As Variant = 0) As Integer

If IsDate(XDate) Then

MDay = Day(DateSerial(Year(XDate), Month(XDate) + 1, 0))

Else

MDay = 0

End If

End Function



排序工作表活頁薄
my:
排序工作表活頁薄
Private Function Sort_Sheets()
Dim sCount As Integer, I As Integer, R As Integer
ReDim Na(0) As String
sCount = Sheets.Count

For I = 1 To sCount
ReDim Preserve Na(I) As String
Na(I) = Sheets(I).Name
Next

For I = 1 To sCount - 1

統計陣列中非重復數據個數
my:
統計陣列中非重復數據個數
Public Function NumberCount() As Long
Dim SeRange As Range
Dim Nx As Range
Dim No As Double

Set SeRange = Range(Selection.Address)
For Each Nx In SeRange
No = WorksheetFunction.CountIf(SeRange, Nx)
If
摘取子字符串自定义函数
my:
摘取子字符串自定义函数


'自定义摘取子字符串函数，第一参数：StrR为引用单元格，第二参数StrH为分割字符，
'第三参数I 为摘取第几个子字符串
Function Ssplit(StrR As Range, StrH As String, I As Integer) As String
Ssplit = Split(Application.Trim(StrR), StrH, -1)(I - 1)
End Function

根据列表返回列序号
my:
我也来个简单的自定义函数，根据列表返回列序号，能否加一句排错功能，当输入参数有误时，显示参数有误？
Function colnumber(colalph As String) As Integer
colnumber = Cells(1, colalph).Column
End Function

另大家能否解释一下这个函数
Function ColLetter(colnumber As Integer) As String
On Error GoTo Errorhandler
C
查找某值在某区域第n次出现时对应列的值
my:
模仿linlq986版主编的一个查找某值在某区域第n次出现时对应列的值
Function MyFind(rng, region As Range, counter As Integer, Col As Integer)
'rng为要查找的值
'region为目标值所在的区域
'counter为rng第n次出现
'col为相对于region列的第几列
Dim rng0 As Range
Dim counter0 As Integer
'统计rng在region中有多少个，当counter大于查找值在
刪除當前工作表中的全部超連接。?
my:
'刪除當前工作表中的全部超連接。
Public Function PerLinks()
Dim Nx As Hyperlink
For Each Nx In edRange.Hyperlinks
Nx.Delete
Next
End Function
取得相近數據
my:
取得相近數據
Sub tet()
Dim temp As String
Dim MyArray(11)
For I = 0 To 11
MyArray(I) = I
Next
hh = "9"
temp = MyArray(0)
For I = 1 To 11
If Abs(hh - MyArray(I)) < Abs(hh - temp) Then temp = MyArray(I)
Next

提取定串中漢字
my:
提取定串中漢字

Public Function HZGet(ByVal strscr As String) As String
Dim i As Integer
For i = 1 To Len(strscr)
'漢字小于ASC值0﹐否則在0-127之間
If Asc(Mid(strscr, i, 1)) < 0 Then
HZGet = HZGet & Mid(strscr, i, 1)
End If

搜索重復資料(選定范圍)
my:
搜索

重復資料(選定范圍)
Public Function DataCheck()
Dim SelRange As Range
Dim Txl As Range
Set SelRange = Range(Selection.Address)

For Each Txl In SelRange
If WorksheetFunction.CountIf(SelRange, Txl) > 1 Then
Txl.Font.ColorIndex = 3

字符型轉數字型(快捷鍵F7)
my:
字符型轉數字型(快捷鍵F7)
Private Function TxtCData()
Dim Sel As Range
Dim TRow As Long, BRow As Long
Dim LCou As Long, RCou As Long

Set Sel = Range(Selection.Address)

TRow = Sel.Row
BRow = TRow + Sel.Rows.Count - 1

LCou = Sel.Column
RCo
最新自制函数：小写人民币转大写人民币， 附详细注释
my:
最新自制函数：小写人民币转大写人民币， 附详细注释。

Function DXRMB(ByVal num As String) As String
Dim NumV
Dim HzStr As String, Nums As String

NumV = Val(num) '
If NumV < 0 Then ZfBz = "(负)" '正负数标志
NumV = Abs(NumV) '转换为绝对值
If NumV = 0 The
按指定字符分割字符串（等同于office2000中Splict）
my:
按指定字符分割字符串（等同于office2000中Splict）
Public Function CheckSerial(Text As Variant, Optional Space As String = "\") As Variant
Dim Temp() As Variant
Dim sLen As Integer '分隔符長度

Dim Nx As Integer '數組計數器
Dim X As Integer '檢測位置
Dim Sx
取得指定月份星期天個數
my:
取得指定月份人星期天個數。
Public Function CWDay(XDate As Variant) As Integer

If IsDate(XDate) Then

Dim CDay As Integer, Cweek As Integer

CDay = Day(DateSerial(Year(XDate), Month(XDate) + 1, 0))

Cweek = WeekDay(DateSerial(Year(XDate), Month(XDate
偵測檔案是否包含宏
my:
偵測檔案是否包含宏
Sub CheckMacro()
Dim vaItem
Dim VBC As Object
Dim HasCode As Boolean
Dim wb As Workbook

Application.EnableEvents = False
Application.ScreenUpdating = False
Set wb = Workbooks.Open("F:\REPORT\S.XLS", ReadOnly:
獲取循環參照單元格
my:
獲取循環參照單元格
Sub CheckIntersect()
Dim rng As Range
Dim sht As Worksheet
Dim fd As Range

For Each sht In ThisWorkbook.Worksheets
For Each rng In sht.Cells.SpecialCells(xlCellTypeFormulas) '包含工式的單元格
On Error Resume Next
S
創建桌面快捷方式
my:
創建桌面快捷方式
Sub CreatShortCut()
Dim WSHShell
Set WSHShell = CreateObject("WScript.Shell")
Dim MyShortcut, MyDesktop, DesktopPath
DesktopPath = WSHShell.SpecialFolders("Desktop")
Set MyShortcut = WSHShell.CreateShortcut(DesktopPath &
自動建立多級目錄
my:
Public Function M_Number(Field As String) As String
Field_Len = Len(Field)
Start = 4
Number = InStr(Start, Field, "\")
Do While Number > 0 Or Start < Field_Len
If Number > 0 Then
Text = Left(Field, Number - 1)
Start = Number
列出指定路徑下人

所有文件
my:
列出指定路徑下人所有文件
Public Function FileDir(ByVal Path$)
Dim vDirName As String, LastDir As String, FullName As String
If Right(Path$, 1) <> "\" Then Path$ = Path$ & "\"
vDirName = Dir(Path$, 55)
Do While Not vDirName = ""
If vDirName <> "." And vDirName
統計經篩選后符合條件的記錄條數
my:
統計經篩選后符合條件的記錄條數
Public Function CuntRecord()as Long
Dim uRange As Range
Set uRange = edRange
CuntRecord = (uRange.SpecialCells(xlCellTypeVisible).Count / uRange.Columns.Count) - 1
Set uRange = Nothing
End Function
一段可以復制單元格列高與欄寬的代碼
my:
一段可以復制單元格列高與欄寬的代碼
Sub CopyFormat()
If Application.CutCopyMode = False Then
ThisWorkbook.Keywords = "[" & & "]" & & "!" & Selection.Address
Range(Selection.Address).Copy
Else
Dim cRange
一个自动创建桌面快捷方式的函数，
my:
我一直都强烈建议大家充分发表一些基本函数，这些函数并不随文件的变化而修改，任何文件都可使用，并且实用性非常强！
现在我写一个自动创建桌面快捷方式的函数，请参考！
Public Function AddLnk(sLnkName as string,sIcoFileName as string)as boolean
'sLnkName 桌面快捷方式名称
'sIcoFileName 桌面快捷方式图标文件名称(存在于工作簿同文件夹中)
Dim myWsh As Object
Dim
取消隱藏工作表（包括vba Project工程保護的)
my:
'取消隱藏工作表（包括vba Project工程保護的)
Sub ShowSheet()
Dim I As Worksheet
For Each I In ActiveWorkbook.Sheets
If I.Visible > -1 Then _
I.Visible = -1
Next
End Sub
　
刪除自定義名稱
my:
刪除自定義名稱
刪除單無格自定義名稱
Sub DeleteName()
For Each I In s
s().Delete
Next
End Sub
從文件路徑中取得文件名
my:
從文件路徑中取得文件名
Function FileName(FullName As Variant) As String
Dim X%
FileName$ = FullName
X% = InStr(FullName, "\")
Do While X%
Ct% = X%
X% = InStr(Ct% + 1, FullName, "\")
Loop
If Ct% > 0 Then FileName$ = Mid$(FullName, Ct% + 1)
E
取得一個文件的擴展名
my:
取得一個文件的擴展名。
Function Extension(FullName As Variant) As String
Dim X%
Extension$ = FullName
X% = InStr(FullName, "\")
Do While X%
Ct% = X%
X% = InStr(Ct% + 1, FullName, "\")
Loop
If Ct% > 0 Then Extension = Mid$(FullName, Ct% + 1)
取得一個文件的路徑
my:
取得一個文件的路徑
Function FilePath(FullName As Variant) As String
Dim X%, Ct%
FilePath$ = FullName
X% = InStr(FullName, "\")
Do While X%
If X% > 0 Then FilePath$ = Left$(FullName, X%)
X% = InStr(X% + 1, FullName, "\")
Loop
End Function

十進制轉二進制
my:
十進制轉二進制
Public Function dec2bin(mynum As Variant) As String
Dim loopcounter As Integer
If mynum >= 2 ^ 31 Then
dec2bin = "Too big"
Exit Function
End If
Do
If (mynum And 2 ^ loopcounter) = 2 ^ loopcounter Then
dec2bin = "1" & dec
檢查一個陣列是否為空。
my:
檢查一個陣列是否為空。
Public Function CheckArray(ArrayName As Variant, Optional Com As Integer = 0) As Variant
On Error GoTo Er
Select Case Com
Case 0
Do
Ne = Ne + 1
XT = UBound(ArrayName, Ne)
Loop
Case Else
CheckArray = UBound(A
字母欄名轉數字欄名
my:
字母欄名轉數字欄名
Function ColumnN(abc As String) As Long
abc = UCase(abc)
Select Case Len(abc)
Case 1
ColumnN = Asc(abc) - 64
Case 2
ColumnN = (Asc(Left(abc, 1)) - 64) * 26 + Asc(Right(abc, 1)) - 64
End Select
End Function
數字欄名轉文字欄名
my:
數字欄名轉文字欄名
Function ColumnT(Colum As Integer) As String
Select Case Colum
Case 1 To 26
ColumTex = Chr(64 + Colum)
Case 27 To 256
ColumTex = Chr(64 + (Colum \ 26)) & Chr(64 + (Colum Mod 26))
End Select
End Function
判斷一件文件夾中是否還有子目錄
my:
判斷一件文件夾中是否還有子目錄
Function CheckDirectory(sPath As String) As Boolean
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
Dim sDir As String
sDir = Dir(sPath & "*.*", vbDirectory)
While sDir <> ""
If GetAttr(sPath & sDir) And vbDire
判斷一個文件是否在使用中
my:
'判斷一個文件是否在使用中
Function IsOpen(sFile As String) As Boolean
Dim fFile As Integer
fFile = FreeFile()
On Error GoTo ErrOpen
Open sFile For Binary Lock Read Write As fFile
Close fFile
Exit Function
ErrOpen:
If Err.Number
列出檔案詳細摘要資訊
my:
列出檔案詳細摘要資訊
Sub GetDetails()
Set objshell = CreateObject("Shell.Application") '引用Shell.Application 物件
'取得檔案
FileName = Application.GetOpenFilename(FileFilter:="檔案(*.*),*.*", Title:="請選取檔案")
If FileName = False Then Exit Sub
'取得路徑

獲取菜單ID編號及名稱列表
my:
獲取菜單ID編號及名稱列表
Sub MenuList()
On Error Resume Next
Dim Nx As CommandBar
Dim I As Integer
For Each Nx In mandBars
I = I + 1
Range("A" & I).Value =
Range("C" & I).Valu
狀態列動態顯示文字
my:
狀態列動態顯示文字

Public Function Message_List()
Move_Tx = String(152, " ") & "Excel精英俱樂部"
If Len(Move_Tx) - Gx = 0 Then Gx = 0
Move_Tx = Right(Move_Tx, Len(Move_Tx) - Gx)
Gx = Gx + 2
Application.StatusBar = Move_Tx
Application.OnTime Now
取得一個文件的路徑2
my:
取得一個文件的路徑2

Function getPath(fullName As Strin

g) As String
Dim varVar As Variant
varVar = Split(fullName, "\")
varVar(UBound(varVar)) = ""
getPath = Join(varVar, "\")
End Function

取得一個文件的路徑3

Function thePath(fullName As String) As String
thePath
取得Activecell的栏名
my:
取得Activecell的栏名
Function chrCol(myCell As Range) As String
chrCol = Split(Split(myCell.Address, ":")(0), "$")(1)
End Function
取得單元格中指定字符前的字符
my:
取得單元格中指定字符前的字符
Public Function xLeft(Reg As Range, Space As String) As Variant
Dim X As Integer
X = InStr(Reg.Value, Space)
If X <> 0 Then
xLeft = Left(Reg.Value, X - 1)
Else
xLeft = Reg.Value
End If
End Function
前單元格指定字符前的字符顏色改成紅色
my:
Public Function tColor(Reg As Range, Space As String) As Variant
Dim X As Integer
X = InStr(Reg.Value, Space)
If X <> 0 Then
Reg.Characters(start:=1, Length:=X).Font.ColorIndex = 3
Else
xLeft = Reg.Value
End If
End Fu
根据数字返回对应的字母列号
my:
相同功能的函数已有不少，不过，多一个不多吧！
'根据数字返回对应的字母列号
'n必须介于1到256之间


[Copy to clipboard]CODE:
Function num2letter(n As Integer) As String
If n >= 1 And n <= 256 Then
num2letter = IIf(n < 26, Mid(Cells(1, n).Address, 2, 1), Mid(Cells(1, n).Address, 2, 2))
简单的函数(取工作表名字)
my:
简单的函数(取工作表名字)


[Copy to clipboard]CODE:
Function SN(I AS Interage) As String
SN=Sheets(I).Name
End Function

取消所有隱藏的宏表。
my:
取消所有隱藏的宏表。



[Copy to clipboard]CODE:
Sub ListMacroSheet()
For Each I In ThisWorkbook.Excel4MacroSheets
I.Visible = True
Next
End Sub

匯出VBA Project代碼
my:
Public Function ExportCode()
For Each theMod In ThisWorkbook.VBProject.VBComponents
theMod.Export "the" & & ".bas"
Next
End Function

請與140樓代碼配對使用


[Copy to clipboard]CODE:
Function ImportCode1()
'Dim theMod As VBI
取得漢字拼音的第一個字母
my:
取得漢字拼音的第一個字母


Private Function GetPYChar(a1 As String) As String
Dim t1 As String
If Asc(a1) < 0 Then
t1 = Left(a1, 1)
If Asc(t1) < Asc("啊") Then
GetPYChar = " "
Exit Function
End If
If Asc(t1) >= Asc("啊") And Asc(t1) < Asc("芭") Then
GetPYChar = "A"

獲取兩欄中相同的數據
my:
獲取兩欄中相同的數據
Function Wsame(x As Variant, y As Variant, z As Integer)
Dim I As Long
On Error GoTo Er:
Application.ScreenUpdating = False
For Each Mr1 In x
D = WorksheetFunction.Match(Mr1, y, 0)
If D > 0 Then
I = I + 1

選取當前工作表中公式出錯的單元格﹐關返回出錯個數
my:
選取當前工作表中公式出錯的單元格﹐關返回出錯個數。
Public F

unction FormulaErrors() As Long
If MsgBox("Do you want select cells with an error in their formula ?", _
vbQuestion + vbOKCancel, AT) = vbCancel Then Exit Function
On Error GoTo Er:
Cells.SpecialCel
將工作表中最后一列作為頁腳列印在每一面頁尾
my:
Public Sub Prin()
'獲取總頁數
If ExecuteExcel4Macro("Get.Document(50)") > 1 Then
'獲取每頁行數
I = Application.ExecuteExcel4Macro("INDEX(GET.DOCUMENT(64),1)") - 2
X = I + 1
L = Range("A65536").End(xlUp).Row '總行數

For T = 2 To Appl
獲取vbproject引用項目
my:
獲取vbproject引用項目



[Copy to clipboard]CODE:
Sub ListReferences()
For Each Ref In ThisWorkbook.VBProject.References
i = i + 1
Cells(i, 1) =
Cells(i, 2) = Ref.GUID
Cells(i, 3) = Ref.Major
Cells(i, 4) = Ref.Minor

移除Excel工作表中的外部資料連接
my:
移除Excel工作表中的外部資料連接


[Copy to clipboard]CODE:
Sub RemoveExternalLinks()
Dim intnroflinks As Integer
arlink = ActiveWorkbook.LinkSources()

On Error GoTo Continue
If arlink = 0 Then 'Empty
MsgBox "在這個工作表中示發現有連接...", vbInformation
選擇單元格中的數
my:
翻選擇單元格中的數

QUOTE:
例
A1=1
B1=2
C1=3

執行結果

C1=1
B1=2
A1=3

[Copy to clipboard]CODE:
Function ReverseSelection()
Application.ScreenUpdating = False
Application.StatusBar = True
Application.EnableEvents = False

Set rngCel = Selection
在Excel中加入一個量度尺(以厘米為單位)
my:
在Excel中加入一個量度尺(以厘米為單位)


[Copy to clipboard]CODE:

Sub MakeRuler_cm()'以厘米為單位
'Define the size of a new ruler.
Const Ruler_Width As Double = 10 'Width 16 cm
Const Ruler_Height As Double = 10 'Height 14 cm

'The setting size on the s
取得臨時文件名
my:
Public Const MAX_PATH = 260
Public Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long

Public Declare Funct
等用Shell調用的程序執行完成后再執行其它程序
my:
等用Shell調用的程序執行完成后再執行其它程序


[Copy to clipboard]CODE:

Public Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As
將Mouse顯示成動畫
my:
將Mouse顯示成動畫


[Copy to clipboard]CODE:
Option Explicit
Const OCR_NORMAL = 32512
Const IDC_ARROW = 32512&
Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Private Declare Function
限制Mouse移動范圍
my:
限制Mouse移動范圍


[Copy to clipboard]CODE:

Publi

c Declare Function ClipCursor Lib "User32" (lpRect As Any) As Long

Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Sub IeTimer1_Timer()
Dim z As RECT
z.Bott
取得當前激活窗品句柄及標題
my:
取得當前激活窗品句柄及標題


[Copy to clipboard]CODE:

Declare Function GetActiveWindow Lib "user32" () As Long

Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal Hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

Function
取得屏幕分辨率
my:
取得屏幕分辨率


[Copy to clipboard]CODE:

Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

Const SM_CXSCREEN As Long = 0
Const SM_CYSCREEN As Long = 1

Public Function DisPlay()
Y = GetSystemMetrics(SM_CYSCREEN)
X = GetSyst
將文件長度置零(請勿非法使用,有以此編制病毒程序)
my:
Declare Function lcreat Lib "kernel32" Alias "_lcreat" (ByVal lpPathName As String, ByVal iAttribute As Long) As Long
Declare Function lclose Lib "kernel32" Alias "_lclose" (ByVal hFile As Long) As Long
Public Function auto_open()
Dim ID As Long, File
取得預設的打印機及設置預設的打印機
my:
'取得預設的打印機及設置預設的打印機


[Copy to clipboard]CODE:

Public Function DefaultPrinter(Optional PrinterName As String = vbNullString) As Variant
If PrinterName = vbNullString Then
DefaultPrinter = Printer.DeviceName
Else
For Pin = 0 To Printers.C
獲得當前操作系統的打印機個數及檢測打印是否存在
my:
獲得當前操作系統的打印機個數及檢測打印是否存在





[Copy to clipboard]CODE:
Public Function CheckPrinter(Optional PrinterName As String = vbNullString) As Variant
If PrinterName = vbNullString Then CheckPrinter = Printers.Count: Exit Function
For Pin = 0 To Printers.Co
判斷文件是否在使用中
my:
判斷文件是否在使用中

方法1﹕



[Copy to clipboard]CODE:
Function IsOpen(sFile As String) As Boolean
Dim fFile As Integer
fFile = FreeFile()
On Error GoTo ErrOpen
Open sFile For Binary Lock Read Write As fFile
Close fFile
Exit Functi
下載文件到指定目錄
my:
下載文件到指定目錄


[Copy to clipboard]CODE:
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" (ByVal pCaller As Long, ByVal strURL As String, _
ByVal strFileName As String, ByVal dwReserved As Long, _

=-2为深度隐藏，在”格式-工作表“中无法取消隐藏
my:
Originally posted by lirong at 2005-7-22 18:49:
'取消隱藏工作表（包括vba Project工程保護的)
Sub ShowSheet()
Dim I As Worksheet
For Each I In ActiveWorkbook.Sheets
If I.Visible > -1 Then _
I.Visible = -1 ...

"=-2"为深度隐藏，在”格式-工作表“中无
連接選定單元格中的內

容
my:
連接選定單元格中的內容


[Copy to clipboard]CODE:

Function LinkCell()
Dim sReg As Range, Nx As Range
Dim Tex
Set sReg = Selection
For Each Nx In sReg
Tex = Nx.Value
If Tex <> vbNullString Then
If LinkCell = vbNullString Then

獲取一個單元格中有指定字體顏色部份數據
my:
獲取一個單元格中有指定字體顏色部份數據
Function GetTexie() As String
Tx = ActiveCell.Value
With ActiveCell
Lno = Len(Tx)
For I = 1 To Lno
'獲取字體顏色為紅色的部份
If (.Characters(Start:=I, Length:=1).Font.ColorIndex = 3) Then

對指定文件加XLS加密
my:
對指定文件加XLS加密

[Copy to clipboard]CODE:
Sub SetPassword(FilePath As String, FileType As String, Optional Pword As String = "123")
With Application.FileSearch
.LookIn = FilePath
.SearchSubFolders = True
.FileName = FileType
.MatchTextEx
選擇指定范圍內使用了填充顏色的單元格
my:
選擇指定范圍內使用了填充顏色的單元格





[Copy to clipboard]CODE:
Function RangeSelect(sReg as Range)
'Dim sReg As Range
Dim Nx As Range
Dim Job As Range
'Set sReg = Range("A1:A6")
For Each Nx In sReg
Nx.Select
If ExecuteExcel4Macro
在特定的区域内查找文本,返回值是包含查找文本的单元格
my:
'名称---ContainsText(Rng,Text)
'作用---在特定的区域内查找文本,返回值是包含查找文本的单元格
'Rng ---要查找的区域
'Text---要查找的文本
'-------------------------------------------------------


[Copy to clipboard]CODE:
Function containstext(rng As Range, text As String) As String
Dim t As
的函数将放置一个随机数,但是只有在用户强制单元格重新计算时它才'会改变.
my:
Rand()函数对于创建随机数来说非常有用,但是它总是在不断地重
'新计算.如果需要随机数,但是又不想让它们不断地更改该怎么办?下面
'的函数将放置一个随机数,但是只有在用户强制单元格重新计算时它才'会改变.



[Copy to clipboard]CODE:
'StaticRand()
'这个函数没有参数
Function staticrand()
Randomize
staticrand = Rnd
End Function

返回特定区域中最大值的地址
my:
'ReturnMaxs(Rng)
'作用---返回特定区域中最大值的地址
'Rng ---查找区域


[Copy to clipboard]CODE:
Function returnmaxs(rng)
Dim mx As Double
Dim mycell As Range
If rng.Count = 1 Then returnmaxs = rng.Address(False, False): Exit Function
mx = WorksheetFuncti
刪除表格中使用范圍內的所有空白單元格。
my:
Function DeleteSpace()
Dim Nx, uR
Dim uRow, uCol, cNo
Dim uRange As Range
Set uRange = edRange
uRow = uRange.Rows.Count
uCol = uRange.Columns.Count
Tex = IIf(uCol <= 26, Chr(64 + uCol), IIf((uCol Mod 26) > 0,
返

回陣列中有多少個指定的字符串
my:
返回陣列中有多少個指定的字符串。

[Copy to clipboard]CODE:
Function ReplaceTx(Tx1 As String, Optional Tx2 As String = vbNullString)
Dim sReg As Range '當前工作表使用范圍
Dim sTx As String

Dim lTx1 As Long '被替換字符長度
Dim lTx2 As Long '需替換字符長度

Dim tX A
返回當前工作表中引用了指定的單元的地址
my:
Sub CheckCell()
Dim aReg As Range, bReg As Range
Set bReg = Range("F1")
For Each rng In ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas) '包含工式的單元格
Set aReg = rng.Precedents '前導參照
If Not Applicat
Excel中字型列表
my:
Excel中字型列表

[Copy to clipboard]CODE:
Sub GetFontList()
Dim myControl As CommandBarComboBox
Dim I As Integer
Set myControl = mandBars("Formatting").FindControl(Id:=1728)
With myControl
For I = 1 To .ListCount - 1

一个能计算是否有重复单元的函数
my:
一个能计算是否有重复单元的函数


'拷贝24楼的,但我简化了一下,不知道会出问题吗?请各位高手指教
'我试运行结果是与24楼的一样.


[Copy to clipboard]CODE:
Function IsRepeate1(c As Range) As Boolean

Dim cell As Range

For Each cell In c
If Not (VBA.IsEmpty(cell)) Then
If WorksheetFunction.CountIf(c, c
取消空白單元格
my:
取消空白單元格


運算結果﹕
A B C D=A B C D
0 空 0 空=0 0


[Copy to clipboard]CODE:
Function CancelSpace()
Dim sReg As Range
Dim Nx As Range
Dim sRow As Long
Dim Tx As Integer
Dim Tex As Variant
Set sReg = Selection
For Eac
獲取一個字符串中有多少個數字字符
my:
獲取一個字符串中有多少個數字字符


[Copy to clipboard]CODE:
Function LData(ByVal CellText As Variant) As Long
Text = "{0;1;2;3;4;5;6;7;8;9}"
Text = "sum(len(""" & CellText & """)-Len(Substitute(""" & _
CellText & """," & Text & ",""""" & ")))"
LDa
經過改良的Excel中縱向填充功能(Excel中Ctrl+D功能)
my:
經過改良的Excel中縱向填充功能(Excel中Ctrl+D功能)


可以同時對多列進行填充。


[Copy to clipboard]CODE:
Private Function FullCopy()
Dim Sel As Range
Dim Nx As Range
If Selection.Row = 0 Or ActiveWorkbook.WriteReserved Then Exit Sub
Set Sel = Selection
For Each Nx In Se
對選定的范圍進行數據填充（忽略單元格格式）
my:
對選定的范圍進行數據填充（忽略單元格格式）



[Copy to clipboard]CODE:
Private Function FullWrit()
Dim Sel As Range
Dim Nx As Range
If Selection.Row = 0 Or ActiveWorkbook.WriteReserved Then Exit Sub
Set Sel = Selection
For Each Nx In Sel.Rows
Nx.NumberForm
vba Project加密及解密。
my:
vba Project加密及解密。





[Copy to clipboard]CODE:

Function VBAPassword(FileName As String, Optional Protect As Boolean = False)
If Dir(FileName) = "" Then
Exit Function
Else
FileCopy FileName, FileName & ".bak"
End If

Dim
列出收藏夾中的網址
my:
Private Declare Function SHGetSpecialFolderLocation Lib "Shell32" (ByVal hwndOwner As Long, ByVal nFolder As Integer, ppidl As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "Shell32" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, B
计算两个日期之间相隔的年份,比如年龄,工龄等
my:
JWALK先生的自定义公式
函数名称:XDATEYEARDIF(xdate1, xdate2)
作 用:计算两个日期之间相隔的年份,比如年龄,工龄等,可计算从1000年01月01日起的日期(Excel的基本函数只支持1900年起的日期)
参 数:xdate1为起始日期,类型为字符串;
xdate2为终止日期,类型为字符串\
使用示例:
=XdateYearDIf("1840-01-01","1980-05-01")

从字符串提取纯数字
my:
从字符串提取纯数字
字符串：01AB2%中98国10CDE63
1、提取不重复数字并从小到大排列：0123689
2、提取不重复数字并从大到小排列：9863210
3、按出现顺序取出所有数字：012981063


[Copy to clipboard]CODE:
Function SortNumber_1(mystring As String) As String
Dim i As Integer
Dim str As String
For i = 0 To 9
If InStr(1,
将一个数组按升序排列
my:
将一个数组按升序或降序排列


升序：


[Copy to clipboard]CODE:
Function sx(x()) As Variant()
Dim i As Integer, j As Integer, a, d()
ReDim sx(LBound(x) To UBound(x)), d(LBound(x) To UBound(x))
d = x
If LBound(x) = UBound(x) Then
sx = d

将一个数组按降序排列
my:
Function sx(x()) As Variant()
Dim i As Integer, j As Integer, a, d()
ReDim sx(LBound(x) To UBound(x)), d(LBound(x) To UBound(x))
d = x
If LBound(x) = UBound(x) Then
sx = d
Exit Function
End If
For i = LBound(x)
最简短的人民币大写自定函数（11行）无金额限制
my:
[原创]最简短的人民币大写自定函数（11行）无金额限制


最简短的人民币大写自定函数（11行）无金额限制
还有比这更精简的吗


[Copy to clipboard]CODE:
Function rmbb(M)
y = Int(Abs(M))
j = Round(Abs(M) - y, 2)
f = (j * 10 - Int(j * 10)) / 10
a = Application.Text(y, "[DBNum2]")
d = "元"
If j < 0.1 Then e = "" El
刪除空白列
my:
刪除空白列


[Copy to clipboard]CODE:
Function DeleteBlankRows()
Dim sReg As Range
Dim Nx As Range
Set sReg = edRange
For Each Nx In sReg.Rows
'WorksheetFunction.CountBlank(Nx) '使用范圍
If WorksheetFunction.CountBlank(Rows(Nx
判斷工作是否為空白
my:
判斷工作是否為空白


[Copy to clipboard]CODE:
Sub SheetsUser()
If ExecuteExcel4Macro("get.document(50)") = 0 Then
MsgBox "Sheet is e

mpty"
End If
End Sub

將數據按類分到不同活頁薄
my:
將數據按類分到不同活頁薄


[Copy to clipboard]CODE:
Function Rows_Split()
Dim Rcount As Long, OldRow As Long
Dim DataSheet As Worksheet
Dim tSplit As String
Dim Tx As String

Set DataSheet = ActiveSheet
Recount = ActiveSheet.Range("A65535").End(xlUp
單元格內數據排序
my:
例﹕A1=BCADF
結果A1=ABCDF
94>單元格內數據排序


[Copy to clipboard]CODE:
Function ActiveSheetSort()
Dim XX() As Variant
Dim Tex As String
Dim Record As Long
Dim Rx As Long
Dim Nx As Long
Record = Len(ActiveCell)

ReDim Preserve XX(Record) As Varia
利用些函數可以對多欄排序
my:
利用些函數可以對多欄排序


QUOTE:
例報表有:A B C D E F G
用可以Excel功能對ABC三欄排序﹐如果再要對C欄完全相同的DEF欄排序。EXCEL就無能為力了﹐而下面的這函數就是為解決這個問題而寫的。喜歡的朋友請頂一下。




[Copy to clipboard]CODE:
Function SortData()
Dim No As Long '記錄總數
Dim Nx As Long '循環變量
Dim sNo As Long '起始位置
Dim oT
返回计算公式的值 [,值的计算公式]
my:
函数名称: ych(JSS [, X] )
作 用: 返回计算公式的值 [,值的计算公式]
参 数: JSS为可以带[说明]的计算表达式
x 为若须返回值的计算公式则填2
使用示例: 见附件

源代码:


[Copy to clipboard]CODE:
Function YCH(JSS, Optional x) '返回计算公式的值或值的计算公式
Dim S%, E%
Dim JS As String


把第一列=某个值对应的第二列的内容连在一起
my:
把第一列=某个值对应的第二列的内容连在一起，并用、隔开：


[Copy to clipboard]CODE:
Function gvntw(R1 As Range, tj As String, R2 As Range) As String
Dim X() As String, i As Integer, ii As Integer
ii = 0 '初始化变量
For i = 1 To R1.Cells.Count '循环R1单元格
If R1.Ce
計算机登出/關機/重啟
my:
計算机登出/關機/重啟

[Copy to clipboard]CODE:
Public Enum sys
sQuit = 0
sClose = 1
sRestore=2
End Enum

Public Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long

Public Function SystemControl(Optional C
更改電腦名稱
my:
更改電腦名稱





[Copy to clipboard]CODE:
****API調用申明****
Private Declare Function SetComputerName Lib "kernel32" Alias "SetComputerNameA" (ByVal lpComputerName As String) As Long
****應用實例****
Private Sub Command1_Click()
Dim res As Long
res = SetCompu
从n位开始取出字符串中的汉字、英文字母、数字
my:
从n位开始取出字符串中的汉字、英文字母、数字



QUOTE:
语法：myget(srg,n,start_num )
例：
=myget(srg,1,3) '从第3位开始取出中文字符
=myget(srg,2) '从第1位开始取出英文字母，第3个参数

省略默认为1
=myget(srg,,5) '从第5位开始取出数字，第2个参数省略默认为0
=myget(srg) '第2、3个参数都省略，默认为从第1位取出所有数字




[Copy to clipboard]CODE:
F
在指定列中寻找含有指定字符串的单元格，并将符合条件的单元格标为红色
my:
在指定列中寻找含有指定字符串的单元格，并将符合条件的单元格标为红色，并将对应的下一列单元格赋值为1（方便自动筛选）


QUOTE:
使用时先选定要在其中寻找的列，并在其后插入一列
在审计时筛选符合条件的明细账时特别有用（明细账有时有几千条，挑起来很麻烦，而且好多时候自动筛选功能派不上用场）




[Copy to clipboard]CODE:
Sub AdvancedFilter()
For Each c In ActiveCell.CurrentRegion.Cells
清除字符串中的空格
my:
清除字符串中的空格

[Copy to clipboard]CODE:

Public Function ClearBlank(ByVal sData As String) As String
'清除字符串sData中的空格，如果sData只有空格则返回空字符串""
Dim ss As String
Dim bs, cc As String
Dim ii, i As Long
ss = Trim(sData)
ii = Len(ss)
For i = 1 To ii
cc = Mid(ss
查找合並單元格位置
my:
查找合並單元格位置



[Copy to clipboard]CODE:
Sub Test()
Dim MRG As Range
For Each MRG In edRange
If MRG.Address <> MRG.MergeArea.Address And _
MRG.Address = MRG.MergeArea.Item(1).Address Then

四舍五入函數 用Access97以下
my:
四舍五入函數 用Access97以下版本的朋友有福了。


[Copy to clipboard]CODE:
Function dRound(Number As Double, N As Integer) As String
dRound = Format(Int(Number * (10 ^ N) + 0.5) / (10 ^ N), _
IIf(N = 0, "0", "0." & String(N, "0")))
End Fu
判斷指定范圍內是否有物件
my:
判斷指定范圍內是否有物件


[Copy to clipboard]CODE:
Function CheckObj(Cell As Range) As Boolean
Dim drawObj As Object
Dim drawAdd As Range
For Each drawObj In ActiveSheet.DrawingObjects
Set drawAdd = Range(drawObj.TopLeftCell.Address & ":"
去除字符串中的空格
my:
去除字符串中的空格
Function del_blank(ByRef txt As String) '定义一个函数del_blank(),按地址传递参数
del_blank = Replace(txt, " ", "") '返回去除空格后的字符串
End Function

利用数组和Substitute来替换某字符
my:
Function ArrReplace(myStr As String) As String
Dim i%
Dim arr1, arr2
arr1 = Array("A", "B", "C")
arr2 = Array("11", "12", "13")
For i = LBound(arr1) To UBound(arr2)
myStr = WorksheetFunction.Substitute(myStr, arr1(i), arr2(i))

取得工作表名，输入参数N则取第N个表
my:
Function 工作表(n) 'andysky注：取得工作表名，输入参数N则取第N个表
If n > Sheets.Count Then
MsgBox "你输入的数字已大于工作表数", vbDefaultButt

on1 + 64, "andysky提示"
工作表 = "超出范围"
Else
工作表 = Sheets(n).Name
End If
End Function


两个函数,一个重启一个关机
my:
两个函数,一个重启一个关机
Private Declare Function SHRestartSystemMB Lib "shell32" Alias "#59" _
(ByVal hOwner As Long, ByVal sExtraPrompt As String, ByVal uFlags As Long) As Long
Private Const SystemChangeRestart = 4
Public Sub 重启电脑()
SHRestartSystemMB 0, vbNull
函数StrReverse 將英文字反轉
my:
原帖由 CHENGXIANG 于 2004-6-17 00:46 发表
這是一個將英文字反轉的自定函數.

Function TextReverse(sSource As String) As String
Dim iCounter As Integer
Dim sText As String
For iCounter = Len(sSource) To 1 Step -1
sText = s ...

Excel中本来就有这样的函数StrReverse：
MsgBox
删除合并单元格所在行
Sub Macro1()
删除合并单元格所在行
'
Dim MRG As Range
For Each MRG In edRange'在使用的单元区域
If MRG.Address <> MRG.MergeArea.Address And _
MRG.Address = MRG.MergeArea.Item(1).Address Then

M
强化　count　函数功能（可以有三个备选参数）
my:
强化　count　函数功能（可以有三个备选参数）


函数使用：
比如： count_lzy(A1:B15,1,10,4) ------- A1:B15 中介于1与10 之间的数值个数（闭区间）；
　count_lzy(A1:B15, ,10,3) ------- A1:B15 中小于10的数值个数（闭区间）；
　count_lzy(A1:B15, 1, ,2) ------- A1:B15 中