Excel2003高级VBA编程---第11章 VBA编程示例和技巧

上一篇 / 下一篇 2006-10-31 21:30:09 / 个人分类：Excelvba

查看( 4003 ) / 评论( 27 )

实例六基础设置

小结：精英博客Md\2b z
本节主要论证如何在vba中进行Excel的基础设置？例如：

1、文本自动换行切换
JP*K Co0Selection.WrapText = Not Selection.WrapText
h5\D3o&ViWX02、自动切换行号和列标
&xdkVxkt0ActiveWindow.DisplayHeadings = Not ActiveWindow.DisplayHeadings精英博客!BOQ4\P]i
3、自动切换网络线精英博客Bj@&bA!s
ActiveWindow.DisplayGridlines = Not ActiveWindow.DisplayGridlines精英博客j+Eh"|1lq#s,~
4、切换工作表标签精英博客'ZX\1|0E
.DisplayWorkbookTabs = Not .DisplayWorkbookTabs 精英博客Z"H`_Ij
5、切换编辑栏精英博客A]+KaU
.DisplayFormulaBar = Not .DisplayFormulaBar 精英博客 c0e C9e'Zx
6、切换状态栏
+E1zt[D1?$F4E0U2M xm0 .DisplayStatusBar = Not .DisplayStatusBar 精英博客 l/wl_1F
7、切换任务栏窗口精英博客%Yy&Ju)_ aAd$e
.ShowWindowsInTaskbar = Not .ShowWindowsInTaskbar
IV'Sht5M0 在实际应用中，如果没有记住这些属性，可以录制一个宏进行相关方法、对象的学习。

具体代码如下：

Sub 自动换行切换()精英博客GqkOEAsi
'切换换行格式，wraptext单元格格式设置文本为自动换行精英博客9F1y"H|$]6l
'只要格式设置为true或者false都可以利用not进行自动切换
7qH~;m"C]SJ/J,M.c0If TypeName(Selection) = "Range" Then
+@3XP#\:x0 Selection.WrapText = Not Selection.WrapText
)~jO"J4F&B#qA"c0End If
*k!i2R#gCa0End Sub

Sub 自动切换行号和列标()精英博客T:T u_ cg?@3W
'利用activewindows的displayheadings属性切换行号和列标
6l(T6\!`t%xR0ActiveWindow.DisplayHeadings = Not ActiveWindow.DisplayHeadings
U_hx1N]0End Sub

Sub 自动切换网络线()
/_9vv#z:e5dt"N@0ActiveWindow.DisplayGridlines = Not ActiveWindow.DisplayGridlines精英博客:nv&K P'aWz
End Sub
:\6X)p$]EE*V/q{.k0Sub 自动切换编辑栏等()精英博客-uFFe,M
With ActiveWindow精英博客3H6[#N#?*G-tx
.DisplayWorkbookTabs = Not .DisplayWorkbookTabs '切换工作表标签精英博客7`nXbx`0V&c
End With
B(o1y?2l.?r0With Application
'_*Gta@P5g(|}0 .DisplayFormulaBar = Not .DisplayFormulaBar '切换编辑栏
B7^SOBMB0 .DisplayStatusBar = Not .DisplayStatusBar '切换状态栏
d zJJ_1S;~g8HR0 .ShowWindowsInTaskbar = Not .ShowWindowsInTaskbar '切换任务栏窗口
)r.N"Jp&a~b0End With
#JWu| T2@z"D/eZ0 精英博客6A/xYb,Vz0YLfhvD
End Sub精英博客j[KX5CjbD

相关阅读:

Excel2003高级VBA编程--第八章代码时间测试 (west_wolf, 2006-10-20)
Excel2003高级VBA编程--第七章批注 (west_wolf, 2006-10-20)
Excel2003高级VBA编程--第十章自定义函数 (west_wolf, 2006-10-20)
提高vba运行效率 (west_wolf, 2006-10-23)
vba编程实例与技巧 (west_wolf, 2006-10-23)
工作簿基本操作应用实例 (west_wolf, 2006-10-24)
Excel2003高级VBA编程---第11章 VBA编程示例和技巧 (west_wolf, 2006-10-26)
Excel2003高级VBA编程---第11章 VBA编程示例和技巧 (west_wolf, 2006-10-31)
第11章高级技巧 (west_wolf, 2006-10-31)
Excel2003高级VBA编程---第11章 VBA编程示例和技巧 (west_wolf, 2006-10-31)

论坛模式推荐收藏分享给好友管理

TAG: Excelvba

west_wolf 发布于2006-10-20 07:54:30: Excel2003高级VBA编程--第七章批注
第七章批注
}L#E.bMV:V
6b MuJ:Anj]!j1、Comment为Range对象的属性
2、Comments返回指定工作表中所有的批注，可以利用For each对工作表中所有批注循环
tX([b!T/ED|V题目：
ib9]I A@(1)根据批注的作者，删除批注
DmZm \j Qq-{(2)隐藏工作表中所有批注精英博客(Q/e8~T1k!?"? z
(3)为区域中添加批注www.officefans.netdm,j[@Gt/BvH
(4)测试Comments(index)返回指定工作表中第index个批注
'T#x8Dy~ec
g;T
Sub 统计批注个数()www.officefans.netS"odOeh
Dim Flag As CommentY,lf*o-h
'1、Comments返回指定工作表中所有的批注精英博客C q@i^;v5c5^ y
'2、用Comment属性返回一个Comment对象
o%W"a&X`9O
wBQ[精英博客For Each Flag In ActiveSheet.Comments&bC._|3_%OT(K
t = t + 1
Next Flag-i@.TB7SR.wq
MsgBox "活动工作表中共有：" & t & "个批注", vbOKOnly, "统计批注个数"
-eN-n"eJ(n'o${2b
End Sub
_-{sVk0KGo$jc]P\
Sub CountComment()
/l6xs,u6IO"zDim Flag As Rangewww.officefans.net'Zx+N5GKXRL
'利用err来判断是否发生错误
8Z#{draRh*x!?www.officefans.netFor Each Flag In ActiveSheet.UsedRange
-Nj0\;C%{"[E$pb(K On Error Resume Next
t
X,tT(u:X t = Flag.Comment.Text(sne~}
If Err = 0 Then k = k + 1
Next Flag精英博客
]D1M*zX#m
MsgBox "活动工作表中共有：" & k & "个批注", vbOKOnly, "统计批注个数"
x;T4}S
e|*Z
`C%S;f1^
End Sub
n
N5l-u4ZB^bTdcSub 选定批注单元格()
6I]Tm3o精英博客Dim a() As Range
Css9P1i1E
Q6nvyy精英博客Dim Flag As Rangewww.officefans.net9C0]"^!s_Z
F!m
ReDim a(ActiveSheet.Comments.Count)
Q*?Y'V6T~9dcp YFor i = 1 To ActiveSheet.Comments.Count
zU7ctO@g~精英博客 Set a(i - 1) = ActiveSheet.Comments(i).Parent
Next i&D1cw*`EkN$Y%^
Set Flag = a精英博客)mgioz
W
Flag.Select
'BI"h?.Ye精英博客End Sub'w[1j XDZ
Sub selectcomment()
'使用编辑定位功能，定位批注，选定单元格
Cells.SpecialCells(xlCellTypeComments).Select
End Sub
o_,C,GG!l精英博客Sub 显示或隐藏批注()
Dim Flag As Commentwww.officefans.net-~/FC5S:X
For Each Flag In ActiveSheet.Comments7k'eO/ruHm-[,Y5f
If Flag.Visible = True Then
i
?B/|;^}4?精英博客       Flag.Visible = False
|,h\(Wt5Q Else
Tw6FG1L JE&Pwww.officefans.net       Flag.Visible = True
Oo|hOr {:GN'S6i.v
End If
  i|.}&s&vM4`
Next Flag
End Sub
V9[&~f.dD`Sub DisHideComment()VDW@Wpe
'利用application的displaycommentindicator属性来显示隐藏批注www.officefans.netgG3b2~v'Kt#b/W
'Indicator表示批注的标识符
"R4x,y)ID
zP bIf Application.DisplayCommentIndicator = xlCommentAndIndicator Then(C4S/i'|@{8O&Y8\1n2^'jt
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
Elsem'd~*@8D-I3xQh)n
Application.DisplayCommentIndicator = xlCommentAndIndicator
End If
7qL)?gFzEnd Sub
jC!C{~)Mq/_Sub 输出所有批注()@s$B z6b(o6fj
]#Br"V~
'在Sheet2工作表中返回Sheet1工作表中所有批注
+l)RCk%y&k4N!Awww.officefans.net'这里使用flag.parent.comment.text返回批注中的内容
e0dy7| ~`"r2P5XDim Flag As Comment
Dim t As Integer
)r5a8g Q"FMi = 1www.officefans.netqK0hPG;g^S4G
With Worksheets("Sheet2")精英博客}u/N^qV'}9e
.Cells.Clear8l'b2HG4vn*Dc
.Cells(1, 1) = "第n个批注"
GJ:Y8P2Gx.} .Cells(1, 2) = "批注地址" pW0G/l,\$[2dK(S"D@
.Cells(1, 3) = "批注内容"
For Each Flag In Worksheets("Sheet1").Comments!H;t;O%k2y
      i = i + 1
^Zt4F4g`精英博客       t = t + 1
      .Cells(i, 1) = t
.P1X.YuFZ'`-hNOZp精英博客       .Cells(i, 2) = Flag.Parent.Address
Xv)\!xLp8}D2HE       .Cells(i, 3) = Flag.Parent.Comment.Text
Next Flag精英博客j:c:bF^d1s
.Columns("B:B").EntireColumn.AutoFitv,og_$Vr
p7L`*`
.Columns("C:C").ColumnWidth = 34
.Cells.EntireRow.AutoFit
^+J S6LE0@}8[!F'NEnd WithN:R&^Mfb_a1M
End Sub精英博客P7t$C9w$i4aM0UI*C
Sub 改变批注颜色()
#l{{9u&hEwwDim Flag As Comment c9o)p r%J
For Each Flag In ActiveSheet.Comments$U${,Q0O.mo4|
  Flag.Shape.Fill.ForeColor.SchemeColor = Int((80) * Rnd + 1) '1-80
  Flag.Shape.TextFrame.Characters.Font.ColorIndex = Int((56) * Rnd + 1) '1-56
Next Flag
End SubU8YH,h&mB
0z0g6g6b6EX
Sub 添加批注()
4LR{OosDim Flag As Range_8a$}w1@(jwZ)C
On Error Resume Nextzkybu!b{
For Each Flag In ActiveSheet.Range("g8:i17")
t = t + 1o:~cm&[[5u
Flag.AddComment.Text "hner:这是我添加的第" & t & "个批注" & Chr(13) + Chr(10) & Date
&CD,~!`8J'}4v5m*K'?
Next Flag
iu8F_'DU-uEnd Sub
rD't)S.Dn \I q精英博客Sub test()
MsgBox ActiveSheet.Range("g8").Comment.Author

End Sub
$G7P7yuIO0L&I;CSub 删除批注()4qY7J!aCWpn
Dim Flag As Range
For Each Flag In ActiveSheet.Range("g8:i17")%HuuP
y#Gb T1k
Flag.Comment.Delete(AD
h3|MB7^t
Next Flag9kW{p@
End Sub

west_wolf 发布于2006-10-20 10:07:05: Excel2003高级VBA编程--第十章自定义函数
第十章自定义函数www.officefans.nethr}^.g]._)~+S(C8b

/[\$WX,{rVO函数一：计算销售佣金)qF bFDh

&Wm7~6e;rF}&~题1：根据销售额和对应的佣金率计算 =Sales*Rate
题2：根据销售额和对应的佣金率以及工作年限计算，工作每满一年佣金在原来的基础上增加一个百分点  =Sales*Rate*(1+Year/100)

%_;Z9RM?/h7Y;F条件             临界点  佣金率www.officefans.netvM*v
abHI
[0，10000）       0    0.08
0oQjMS.h7C[10000，20000） 10000 0.105www.officefans.netv6L+e7}WD0bX
[20000，40000） 20000 0.12Jm ^[t
[40000，无穷） 40000 0.14

7zZ8](z'B0Ewww.officefans.net计算方法：V7o)V0C0F)S
1、利用vlookup函数的模糊查找：=VLOOKUP(B2,$B$14:$C$17,2,TRUE)*B2 定期维护佣金率
2、利用if函数结合&连接符突破if七层嵌套问题：=IF(AND(B2>=0,B2<$B$15),B2*$C$14,"") &IF(AND(B2>=$B$15,B2<$B$16),B2*$C$15,"")&IF(AND(B2>=$B$16,B2<$B$17),B2*$C$16,"")&IF(AND(B2>=$B$17),B2*$C$17,"")
"T`X.td$\%V'G3、利用自定义函数，代码如下：I,K T)x&?/[7}b
Function Commission1(Sales, years)
Ab%]Z7B XK:s"wUfO'计算销售佣金，工作每满一年，销售佣金在原来的基础上增加一个百分点
Const Rate1 = 0.08
G
A7oUe4msOXmOxConst Rate2 = 0.105C}T
EM!XL
Const Rate3 = 0.12
2o8a \yS(Wwww.officefans.netConst Rate4 = 0.141Ro$f:LH"ar
Select Case Sales
a*?g6]M?e Case 0 To 9999.99 'Case a to b 表示[a,b]两边都是闭区间www.officefans.neti O3s*x N
   Commission1 = Sales * Rate1www.officefans.net4G4?+Qd8w:GZxe
Case 10000 To 19999.99i&RowO$E6mm
   Commission1 = Sales * Rate2
Case 20000 To 39999.99
   Commission1 = Sales * Rate3
Case Else
   Commission1 = Sales * Rate4.eU*[l9g&Y5["xUb-SK
End Select.h
L&^0GGdDR
'每工作满一年，佣金在原来的基础上增加1个百分点
Commission1 = Commission1 * (1 + years / 100)
End Function
(PiJ:De$g3C"[
Y`精英博客*a DI8v c5G)@[z
Sub 计算销售佣金()
’在工作表中设计一个窗体按钮，执行此代码e1Z5mzCs
Dim Saleswww.officefans.netwyc3L4q
Dim years As Integer2T
M0Y1v+U@
[!M7TYoP!Z/J%A
Sales = Val(InputBox("请输入销售额：", "计算销售佣金")),W
UXMj0E
years = Val(InputBox("请输入工作年限：", "计算销售佣金"))'p&Wbe,zqv
精英博客^f.U@*O3e!tNm,a S
y = MsgBox("您的佣金为：" & Commission1(Sales, years), vbYesNo, "计算销售佣金")1x8s%m#TMT'{'f4s
If y = vbYes Then '这里使用msgbox信息框，当单击是的时候，调用该过程本身
2Oij6O
bu+}
Iv/Xawww.officefans.net 计算销售佣金
W/od#n}j0s{-v-JEnd If
}d"V(?X:M{cEnd Sub
enE9vbK)a*I1n`Kx V+M8U
函数二：随机抽取某区域中的一个单元格
wA7s'Lm"q(w4[3k#Y5E:d
目的：理解Optional定义变量和非易失性函数Volatilexs,zUG{J

"S2mi3G}精英博客1、易失性函数：顾名思义该函数很容易改变，也就是无论何时在工作表任意单元格输入数据，易失性函数都需要重新计算，结合本例，只要在任意单元格输入数据，易失性函数都重新计算
5co0l
t!^N*_2、非易失性函数：顾名思义该函数不容易改变，也就是只有在函数中的参数值发生变化时，非易失性函数才重新计算，否则不计算，结合本例，只有在a1:a10输入数据，非易失性函数才重新计算，否则不计算GD(n&CZ"O4}*C
3、Optional申明变量，表示该变量为可选参数www.officefans.net
Z!}xG4Y7a
4、假如Region为一个range对象区域，那么Region(i)表示区域Region中第i个对象

代码如下：
+]m&yIL_精英博客Function UnderstandVolatile(Region As Range, Optional FlagBoolean As Boolean = False)
'利用optional定义变量表示该变量为可选参数^T~X0Y
'理解非易失性函数精英博客1wD[`ZX3AN
mQ
'函数功能：随机抽取Region区域中的一个单元格值4kYRU)D"cx+Cw
'当application.volatile true时，表示易失性函数
Application.Volatile FlagBoolean
'产生[a,b]之间的随机整数 Int(rnd()*(b-a+1)+1)
wy!J+`i
ja[*GUnderstandVolatile = Region(Int(Rnd() * (Region.Count) + 1))Q#`0w AM"Y#dFT@Hk
End Function
0e&VP/T6~.J5K O
+`O
]
NRa.l4o `8oA精英博客函数三：利用Optional来确定自定义函数是一个多单元格数组函数还是一个普通函数 MonthNames(Optional Mindex)
5n]}S*f4p|g
hfK函数功能：返回月份
可选参数：+cY3^1iG5@v)C
1、当无参数时，返回一个多单元格数组公式，横向数组，将一个数组直接赋值给自定义函数精英博客7zia+CXpf
2、当参数大于等于1时，返回对应月份，如参数为1，则返回Jan，参数为13，也同样返回Jand6Qra8`
R8^(u S%t
3、当参数小于等于0时，返回一个多单元格数组公式，垂直数组精英博客.Z(s(_nTHW$A0[VkeC
精英博客I
Q6C6Q[J1fb
代码如下：
Function MonthNames(Optional Mindex)精英博客E0S*w5H\
'返回月份
'Ismissing(t)表示t是否传递给过程，如果没有传递，则返回true
mo,AGA7f
y
@精英博客Dim AllNames As Variant精英博客X{%Xf:p[
AllNames = Array("Jan", "Feb", "Mar", _
2Fh/g%fIVS#^DL       "Apr", "May", "Jun", "Jul", "Aug", _精英博客7jz5H]*z$S
H5XWW
      "Sep", "Oct", "Nov", "Dec")M,U[B)m5x.A
If IsMissing(Mindex) Then7PVS(DJ
MonthNames = AllNames精英博客d'Wo]H:FP-oX7C
Else
8Ub;ab;aT%__o*h(QMG}  Select Case Mindex
   Case Is >= 17l0d#\
C6}7\ O
      '如果参数为1，则返回Jan，为数组的第一个元素，故应该用(Mindex-1 mod 12)，数组的下限为0，即AllNames(0)
      MonthNames = AllNames((Mindex - 1) Mod 12)
\n@lePGk0E%Pswww.officefans.net    Case Else
      MonthNames = Application.WorksheetFunction.Transpose(AllNames)
(nD#O
E,fX$X精英博客  End Select精英博客?Z(p2x$hA
End If精英博客n(Tb^{/m)C
End Function
_:f4w |&Ti0R;_www.officefans.net*B(K5|p?lPm
这里使用一个ismissing函数，该函数主要是用来测试是否将参数传递给过程，如果没有传递，则返回TRUE。'e^i.]A*d
如：在工作表中输入=MonthNames()此时并没有传递参数给过程
,zY0D&J(U_"U Tk7u}m*s_2b
函数四：颠倒字符串
目的：运用vba函数和如何操作字符串
?+e-}}Ta精英博客]y"ob-@:DiW
vba函数:
&dWU'lrN
h1、StrReverse(String)返回反向字符串，当string为空值时，则函数返回空字符窜，如果无参数，则返回null-MC!u2P3{1P/G5tl
2、MID(String,i,n)从字符串string的第i个位置开始提取长度为n的字符串
函数使用for i=len(string) to 1 step -1
            n=mid(string,i,1)
         '遍历字符串中的每个字符，此方法可以运用到数字与字符分离或者字符串中各数字求和等
      next i oI}:^$wN

,s~ u T:k0i&A:M|Function MstrReverse(Mstring) As String
1hM*bd/{il'利用vba函数StrReverse返回反向字符串
+|7G K#nqXF(GMstrReverse = VBA.StrReverse(Mstring)
End Functionwww.officefans.netT4O%h
vVR t4J!p
Function Mstrreverse1(Mstring) As String
y9M(p a*MO
Z精英博客Dim i As Integer
7uT%C@/fQ aY{bwww.officefans.netFor i = Len(Mstring) To 1 Step -1@J p
BrwE};k(A
Mstrreverse1 = Mstrreverse1 & Mid(Mstring, i, 1)www.officefans.net|i2X9D`su
Next i精英博客%Sd2S,U@V
End Function
!l?:i Q!Dj)mSub Mstrreverse2()
Mstring = InputBox("请输入字符串：", "反向字符串")
If Mstring = "" Then Exit Sub
jT K}~s(YOi4v5OW1PMsgBox "字符串：" & Mstring & "的反向字符串为：" & vbCrLf & MstrReverse(Mstring), vbOKOnly, "反向字符串"
.gL$g;OE]:Ln
End Sub
m#Rt:r/r%@D6B1p^Z{2e1C
小窍门：在实际输入vba代码时，可能没有熟记vba常量或者vba函数，此时可以在vbe中按ctrl+j返回常数列表，供选择。或者输入vba.则返回vba函数供选择。

函数五：字符串全部大写或者全部小写 AlUcLcase(Mstring, Optional Mboolean As Boolean = True)Wd'[j,T:r|AXXT

;i,C2NR??
K算法：
2a1Cs#S"t"UQ精英博客1、遍历字符串中的每个字符
k
U2u5W-d)o
zR"|2、对字符串中的每个字符进行判断3rg}`*mizC
条件一：如果函数的第二个参数省略或者第二个参数为TRUE时，表示要将字符串全部大写
^e]zQ9WokX1、如果ASC(字符)在[97，122]，那么，表示该字母为小写字母需要转换。转换字符=CHR(ASC(字符)-32)www.officefans.net8['`*z[*Z3?Q
2、如果不满足上述条件，表示字母表示大写字母或者非字母，此时不需要转换，只需字符连接
7xng'^C,i+R条件二：如果函数的第二个参数为False时，表示要将字符串全部小写精英博客:E5zZh|%phZ
1、如果ASC(字符)在[65，90]，那么，表示该字母为大写字母需要转换。转换字符=CHR(ASC(字符)+32)
*k)B&k"zim精英博客2、如果不满足上述条件，表示字母表示小写字母或者非字母，此时不需要转换，只需字符连接
x]9yc[3t
?
f5V5|vH/Tm
[9z#x精英博客vba函数Zo4P
][a9x:_
1、ASC(字符)表示返回字符的ASICC码，相当于EXCEL工作表中的CODE函数PvF6on5a,j
2、CHR(数字)表示返回数字对应的字符，相当于EXCEL工作表中的CHAR函数
3、UCASE(字符)表示将字符全部大写，相当于EXCEL工作表中的UPPER函数www.officefans.netbU.p} Gfi/g{%i
4、LCASE(字符)表示将字符全部小写，相当于EXCEL工作表中的LOWER函数X/T)cO;e7I1K
+`w#C5e+{U7Ccg}4\
代码如下：F8C9^F0S3d Er%G

Function AlUcLcase(Mstring, Optional Mboolean As Boolean = True) As Stringwww.officefans.neti8[-S*Xo(mg
'字符串大小写转换，如果省略第二个参数，则将字符串全部大写显示，否则小写显示
5IO|GXtB精英博客Dim i As Integer
Dim Mlen As Integer
'm)\0A*JS)twww.officefans.netDim SngString As String
,hqzGTS`4aEwww.officefans.netDim Mcode As Integer
*Rn#nK!j4[2L1@Dim AimString As String
:U-WYd(x6@Mlen = Len(Mstring)
For i = 1 To Mlenwww.officefans.netAU$oSUw^T;n
  SngString = VBA.Mid$(Mstring, i, 1)
  Mcode = VBA.Asc(SngString)精英博客Kvs6m#EG4B
  '注意下面的条件，Ismissing表示当参数省略时，或者当参数为True时，表示将字符串全部大写精英博客7v/t%jY*fm8{&JVR
  If IsMissing(Mboolean) Or Mboolean = True Then精英博客/rNY ]ny
   If Mcode >= 97 And Mcode <= 122 Then
!\(_-AO"r|Rm`&pwww.officefans.net          AimString = AimString & VBA.Chr(Mcode - 32)
k*N/\"o%jZD[    Else
3FZA6e^?._www.officefans.net          AimString = AimString & SngStringwww.officefans.net"v`b"Si7I
   End If
|(~c6FCl3R7DbSwww.officefans.net  Else
eF'E&B
Q%Nv%@www.officefans.net    If Mcode >= 65 And Mcode <= 90 ThenF%^zZ4g;d
oH
         AimString = AimString & VBA.Chr(Mcode + 32)
`-_2|x_
hvwww.officefans.net    Else
aC.K?
pqn yh8ewww.officefans.net          AimString = AimString & SngString"Rgw(qu4cX/P|1@R$}
   End If
QL+[
K2p;}  End If
FZP h`Rs1CNext iW;INhNA
AlUcLcase = AimString
FM2@$m4?A(k3Swww.officefans.netEnd Function精英博客7l9k8qE0m:s~;^tN^

c#N7H!g}6LFunction AlUcLcase1(Mstring, Optional Mboolean As Boolean = True) As String
-T$eH|'Q ^(I精英博客'字符串大小写转换，如果省略第二个参数，则将字符串全部大写显示，否则小写显示V vl.A H(oD'?
If IsMissing(Mboolean) Or Mboolean = True Then
Kc{.]gwww.officefans.net    AlUcLcase1 = VBA.UCase$(Mstring)
ZI/kO%[5\1? ElseLFe;Gtx4~]
AlUcLcase1 = VBA.LCase$(Mstring)
&TDP%b]-k&]w-FH精英博客End IfltQ)~#Z ^2j+W#~
End Function
1NVK-YU"B精英博客
r
FC6WG%P1i精英博客
&@(f@Z&GCzJr
K
`h!O"a*|

xcd 发布于2006-10-24 17:49:59: 辛苦了楼主，谢谢无私的分亨:victory:

xcd 发布于2006-10-24 17:53:49: west_wolf 兄，收下参考了。THANK YOU

zz5151353 发布于2006-10-24 19:32:33: 太好了,也太感謝 west_wolf 兄精彩的發表,一一收藏,謝謝 !!!

zz5151353 发布于2006-10-24 19:38:32: west_wolf 兄精彩的發表,有用一一收藏, 謝謝 !!!

west_wolf 发布于2006-10-26 10:27:36: Excel2003高级VBA编程---第11章 VBA编程示例和技巧
实例一：利用EXCEL的FileSearch属性批处理查找文件
vU5|4T9X9?1K

{0T,o9J2hLwww.officefans.net下面实例主要论证以下几个问题：
1、Application的FileSearch属性，该属性返回一个FoundFiles对象，也就是根据指定的条件，查找出来的满足条件的文件集合，可以利用For each对该集合进行循环。如：要查找D盘根目录下，所有TXT文件
Z2V!b^oNE'下面的代码返回一个FoundFiles属性精英博客4?.xQ3y8P"J.u
With Application.FileSearch
8O8dVA:Pc5N"Twww.officefans.net .LookIn = "c:\"
1g-VVi#]6|0o .FileName = "*.txt"`4G4w9Y#E@
Z
.Execute
OY/h0kNf!}q!}
'对上述属性进行操作
i=1www.officefans.net-\fn/a#A"ID*r8Z
for each fs in .FoundFiles
7}4]cS9Yz with activesheetW7l;C(F)|
   .cells(1,1)="序号"
   .cells(1,2)="路径"
.c)?1GE@3tH    i=i+1 精英博客'P _/t}K8?#|
   .cells(I,1)=I
   .cells(I,2)=fs
_p,M'?4sOe2q Le end withQhy8\3J_qM}6s
next fs
2、利用工作簿的opentext方法，将文本文件导入到工作表中
\}1}7@N3iCS,dl3、过程调用，如果某些过程比较通用，最好使用该方法，以提高代码编写效率
{@$D'b)@3W9Ho1Kz+FCs8T"I`vJ#|
具体实例：
JB&W(S*MR$|Sub FileProcess()
'文件批处理，将某文件夹下所有文本文件导入到excel工作簿中
Dim FileFind As FileSearch
Dim fs As Variant精英博客5}nsSYs
Dim FilePath As String
3x#A.\O/d&C)p#U精英博客Dim FileStyle As String
FilePath = ThisWorkbook.Path & "\"
$i;DM9wV2T_\cFileStyle = "*.txt"精英博客 N}"Xd'P]
With Application.FileSearch
7Q"c3KH-d^P{-E,_ .LookIn = FilePath
Cp!y2V,c[h%bY精英博客 .Filename = FileStylesY(Q"~T8A)jL
.Execute
$wfJ
Lp.T&A.sS If .FoundFiles.Count = 0 ThenFQ9{_
Y/XZ"n3A
X$h
      MsgBox "没有找到指定类型的文件"
      Exit Sub
End If
For Each fs In .FoundFiles
@(mbt
i"_q       Call EveryText1(fs)
Next fs
1hIlQ0iEnd With
8C9A*\GP7r%r*C4_[
tN2sEWeuZ&s;B+^End Sub精英博客 v2n-^_7?!o
K2P$a]$I

Sub EveryText(fs)
fOK4djVQa8|PWorkbooks.OpenText Filename:=fs, startrow:=1
Range("d1") = "代码"
Z9KD8?2Pya%uRange("e1") = "个数"
d-BK@xwww.officefans.netRange("f1") = "金额"www.officefans.net"W$P{$`4d m6pzp
N
Range("d2") = "A"
Range("D3") = "B"
$u&O3V#s
f^%S;dRange("D4") = "C"
,]C){tga]-Ewww.officefans.netRange("E2:e4") = "=countif(b:b,d2)"
#Y-~'R+L)K~uewww.officefans.netRange("f2:f4") = "=sumif(b:b,d2,c:c)"精英博客`2zJv5^6E
End Sub*N{pkAO3X
Sub EveryText1(fs)
s-Y@IA&sqDim i As Integer
i = 1
!@6N2a
cf4w*Oy:t HL!EWith ActiveSheet
.Cells.Clear
Jj9B9^)Wo5j*swwww.officefans.net .Cells(1, 1) = "序号"
5@%d3F+hz(qF8awww.officefans.net .Cells(1, 2) = "文件路径"
精英博客
RJ@-~#xM
i = i + 1精英博客fNx a/V0NR
G
.Cells(i, 1) = i - 1z$dgSL0DW
.Cells(i, 2) = fswww.officefans.netMY8|X1Gx

@0Y.o2ki ~)Hk/] .Cells.Columns.AutoFit
End With,zs/]%Ttb
s&RYb
End Sub
!Z0hf8T-W*^n~www.officefans.net
|'V+P
kF1nRU精英博客实例二：填充单元格，测试教训
ZN
R5]Lx1、尽量减少对象的访问，尤其在循环中。适当情况可以考虑数组替代对象，最后再将数组赋值给对象X!Vb/ckh3H/~
2、在内存中一维数组只能是列数组，如果需要给行赋值，则需要利用工作表函数transpose进行转置
"p ^ ]+v%]T^r p3[@www.officefans.net3、尽量明确变量的类型以及常量的定义，以方便日后，修改代码
-i[HsLBZqE3、有点疑问在时间测试时，每次时间都不一致，更加不解的是代码运行时间有时还为负，不可能啊！
:}Mm
j7s
"e1lI
h7t4iH5wx;T代码如下：
Sub 填充单元格()
Dim StartTime As Long
;?"T#sE,D7L~-V1c精英博客StartTime = Timer,p/n|4ke
MsgBox "测试直接填充单元格时间"D!c.C.v?5e
Const cols = 200
%|
X*u5Bn)FMR-{With ActiveWorkbook.ActiveSheet精英博客!Ff"A@"D ?
.Cells.Clear
y2X9u8l5w@tHcv? For i = 1 To colswww.officefans.netI.wO
_.ME%zO,d-[
   .Cells(1, i) = i
Df+|F#f,Yli6I精英博客 Next i
.Cells.Columns.AutoFit
End With
MsgBox "利用单元格赋值填充单元格共需要的时间为：" & Format(Timer - StartTime, "0.000") & "秒"2L6WMbHnH$wW

End SubGD.V;i$`OGh
Sub 数组填充()d&@Ezx:nkq5v
Dim StartTime As Long
R{8T2rg!s精英博客Dim a()
6F$v*G4u
NZStartTime = Timerwww.officefans.net%FJ,k[&o[G'wma&e
MsgBox "利用数组填充单元格时间测试"
/N
E.ED#pLConst cols = 200
ReDim a(1 To cols)
'数组赋值www.officefans.net-fQ5`)?xqH*e
For i = 1 To cols
0RV0^9ga j/p  a(i) = i
Next i
"G[]:k(PQWith ActiveWorkbook.ActiveSheet精英博客nkb|:V6OR9M
.Cells.Clear^:w ?!e|PQ
.Range(Cells(1, 1), Cells(1, cols)) = a
:~3G(G8V`R .Cells.Columns.AutoFitwww.officefans.netfiKv
o9D*D
End With
p,P%ov}-iMsgBox "利用数组赋值填充单元格共需要的时间为：" & Format(Timer - StartTime, "0.000") & "秒"精英博客 tP1EBpT9V!\

oA5b/^k~)^cEnd Sub

5H%`g
@O?Sub 填充单元格行()www.officefans.nethckh(~t3iMQ
Dim Marray()
'W'}j
iSwww.officefans.netDim i As Long 'i>32767 如果此处定义为整型，则溢出
;yP*zJU-xDim StartTime As Longy5?,M)Gi
Application.ScreenUpdating = False
]*re0b0DStartTime = Timer

Q.Gs7z
kConst Row = 40000
ReDim Marray(1 To Row)
Cells.Clear
)r8p2Pf9}
XC8oJFor i = 1 To Row
  Marray(i) = i6a'n&l-Vs]
Next i
$},X_:i
\3JkRange(Cells(1, 1), Cells(Row, 1)) = Application.WorksheetFunction.Transpose(Marray)www.officefans.net F0t%s-DR^

G?lDv6y(g'下面的数组为列数组，所以需要利用工作表函数transpose转置
z8ia0GG(_'Range(Cells(1, 1), Cells(Row, 1)) = Marraywww.officefans.net#I"@S&A2fC0R
Application.ScreenUpdating = True
MsgBox "共填充了：" & Row & "行" & vbCr & "利用数组赋值得时间为：" & Format(Timer - StartTime, "0.00") & "秒"
,^3t2A7OjD/Wat!M0Iic? U cW/Z;N`
End Sub6C{7E IQ oi
Sub 填充单元格行1()精英博客S,tB6hK/U
Dim i As Long 'i>32767 如果此处定义为整型，则溢出%[}OF"})vs{
Dim StartTime As Long
Application.ScreenUpdating = False
cp'QgZ+K*\5c*t精英博客StartTime = Timer
lO!?B
j?H2pz-@
AConst Row = 40000www.officefans.netQ(wV[,XFV
Cells.Clear
0j1G&fq3TAFor i = 1 To Row
  Cells(i, 1) = i&RT _u%Z{?y0D0V6P
Next i
,OzuIW:RT/J精英博客Application.ScreenUpdating = True|"I-}kgR;Y
MsgBox "共填充了：" & Row & "行" & vbCr & "在循环中引用对象，直接赋值得时间为：" & Format(Timer - StartTime, "0.00") & "秒"
U.L/i0C*o_End Sub
_+H{QY_
;P/R3E@v%E精英博客Sub 利用数组填充单元格行65536()
S Qu+D+h#GMDim Marray()
[[YeJ2[7Bj7tDim i As Long 'i>32767 如果此处定义为整型，则溢出
Dim StartTime As Long
X/p3J5G5E&u!S-D-{Application.ScreenUpdating = FalseH4R[B*W9C
StartTime = Timerwww.officefans.net
~'i3m-I/S'T
Const Row = 65536
^7tmFQnON6l4YIReDim Marray(1 To Row)3y3]
q
}L ?xO
Cells.Clear
E/|k%`B&{*UjFor i = 1 To Row
d:G)sw_Gwww.officefans.net  Marray(i) = i
@ey1R~gDCnNext iwww.officefans.netOZx;@$P
Range(Cells(1, 1), Cells(Row, 1)) = Application.WorksheetFunction.Transpose(Marray)
y$TZ"|)A7u9T| d精英博客
'下面的数组为列数组，所以需要利用工作表函数transpose转置精英博客SLs
sjUSN9K*}
'Range(Cells(1, 1), Cells(Row, 1)) = Marray
Application.ScreenUpdating = True
$uayd1or^6VMsgBox "共填充了：" & Row & "行" & vbCr & "利用数组赋值得时间为：" & Format(Timer - StartTime, "0.00") & "秒"

End Sub Uh.H7u6`8@S/xgD!N
Sub 直接填充单元格行65536()
Dim i As Long 'i>32767 如果此处定义为整型，则溢出
l/hUkL9z4HPDim StartTime As Longwww.officefans.netAiG*B5VS-O9r
Application.ScreenUpdating = False
+w$Y!f\`dh
{#jStartTime = Timeri)^ lbnJBC
Const Row = 65536
3OU$v2dK8l精英博客Cells.Clear
CBAPdpFor i = 1 To Row
}/t3tAE!]8]|{W
pwww.officefans.net  Cells(i, 1) = i
Next i
Application.ScreenUpdating = True
FH)x^7sW!Q精英博客MsgBox "共填充了：" & Row & "行" & vbCr & "在循环中引用对象，直接赋值得时间为：" & Format(Timer - StartTime, "0.00") & "秒"t$W QTH&o
End Sub1CB#Q,E \Pi7\A$I
Sub 利用数组填充整个工作表()
+K$F
D#zolwww.officefans.netDim i As Long
b)l/[N,X#NMLkp'注意变量的声明，如果知道变量的范围最好将其明确变量类型，以提高代码速度
$ZJ
O!U5U"N:JDim j As Integer
ak {$|"ODim StartTime As Long
Dim Marray())ku;[]e
g#D#J
Application.ScreenUpdating = False
sD?&\-AT-~
Cells.Clear*A]gQstNP](@
StartTime = Timer
T;f)V
kU/}'[Const irow = 1000
v4R?8j!Y[U}Const jcolumn = 256www.officefans.netO0]Rk$N|2ObN
ReDim Marray(1 To irow, 1 To jcolumn)www.officefans.net'O8I4k(~%W
2e,[&N;NU
For i = 1 To irow
D(N/S)b5p;j|R(jwww.officefans.net For j = 1 To jcolumn1l+h&YEo6y~
   Marray(i, j) = i * j
Next j8s9c!T6yWu2s
Next i精英博客
M%_]1cXK[*X*\D
Range(Cells(1, 1), Cells(irow, jcolumn)) = Marray0ZUQQ'`uKU d
Application.ScreenUpdating = True
B3D vBjZ~精英博客MsgBox "共填充了：" & irow & "行" & jcolumn & "列" & vbCr& "在循环中引用对象，直接赋值得时间为：" & Format(Timer - StartTime, "0.00")& "秒"
6M
o f]k7~]End Sub

www.officefans.net(gG)l'U]2dd
|C
此外，各位版主，为何我的博客不能再发表日志的时候上传文件，只能上传图片？

west_wolf 发布于2006-10-31 21:25:58: Excel2003高级VBA编程---第11章 VBA编程示例和技巧
实例五 vba中运用excel工作表函数
,[1mx1srwB\*u'以下代码主要测试parent属性，即对象的父对象(上一级)}1DpWf3]
Function WsName(Optional Rng As Range) As Stringwww.officefans.net'{ql(qh3N'G$l
N
'optional在函数中表示optional命名的参数为可选参数
'利用rng是否存在，来判断函数是否有参数
If Rng Is Nothing Then
{5x:Nf7v7I-G'Z WsName = ActiveSheet.Name
{T0C;~Id0f+vwww.officefans.netElseZ)ox#Xb
WsName = Rng.Parent.NameDngLLNv%} f
End If!Jf#[}'m"S'?"[T
End Function
K~h+X/?rJwww.officefans.netFunction WbName(Optional Rng As Range) As String
If Rng Is Nothing Then3b aD4N1W7T
  WbName = ActiveWorkbook.Name
U.?`2P
v2`sElse+y"`~6Y_5Z
  WbName = Rng.Parent.Parent.Name
End If
w*mL(UJ:Q/n?XZ{www.officefans.netEnd Function
Function AppName(Optional Rng As Range) As String:Xv9f.ZQNam
If Rng Is Nothing Then
w2vZ8k b{:c^-nf"a
  AppName = Application.Name精英博客nAgd8i$x8?y
Else
  AppName = Rng.Parent.Parent.Parent.Name
C;vf*q8V E6['W精英博客End If
`
k
hw1^%UEnd Function
`CNLwW%Zy9Gwww.officefans.netFunction SumCountIF(DataRng As Range, Llimit, Ulimit, SCBoolean As Boolean)www.officefans.net1j?7B+vELm/Y;M+|
'条件求和计数，这里的上下限都是闭区间，当SCBoolean为true时，求和`:X%}2YnxU
Dim Rng As Range精英博客;K0sp6onE
Dim t
(v8D/n*BK9A,cwww.officefans.net'下面代码数据多时，速度会减慢，建议直接使用工作表函数1Z#Zb{
iYx~2m
'For Each Rng In DataRng
I4L2~QyGdC'  If Rng >= Llimit And Rng <= Ulimit Then
Rlr!WMc5v"`6V精英博客'    Select Case SCBooleanN6U&\)EV
_
'       Case True
'          t = t + Rng
'       Case Else
"o r?r0u7]Z$^|'          t = t + 1
,ONr$aF1|'    End Selectwww.officefans.netX%Xg3Uab
'  End If1xn5S"qH-K
'Next Rng_;f){l3J:|2~(?l+K
If Llimit >= Ulimit Then&],R P'yf[v;q'L S/U!Il
k = LlimitjgVFZ&yh'C
Llimit = Ulimit*V}{
^P"O+{
Ulimit = k
*l(x
E4|;n4M8K0aEnd If
With Application.WorksheetFunctionwww.officefans.net#xU(C&\4^w9Ym4O
If SCBoolean = True Then

X:czgB!R Y*? www.officefans.netzW*]}g
   t = .SumIf(DataRng, ">=" & Llimit) - .SumIf(DataRng, ">" & Ulimit)9N&m0b6pDz[1@
Elsewww.officefans.net6wo`&FYUt
   t = .CountIf(DataRng, ">=" & Llimit) - .CountIf(DataRng, ">" & Ulimit)www.officefans.netTP8L8E$n9r_[B

{W|rI3M2|End If
SQ@o%Kz(|End With
SumCountIF = t3}8XJ SX#@&_
End Function
/mn!SU(@7c$fFunction SumCountVisible(DataRng As Range, SCBoolean As Boolean)S z'RG4y%t
'可见单元格求和计数，将该函数设置为易失性函数精英博客'[6iI"Z+s"w^#xS3Y2]
Dim Rng As Range
P7Aav#_3b#HM8_9bKApplication.Volatile True
+`|3J3A|g.h0jwww.officefans.netFor Each Rng In DataRngwww.officefans.neteG#],Zj:~1bx8x(y
  If Rng.EntireColumn.Hidden = False And Rng.EntireRow.Hidden = False Then
'j!COcb+i3w6\3h精英博客    If SCBoolean = True Then精英博客,cFw4q7Rw#j
      t = t + Rng'p WV@O2K
   Else精英博客H[JWx9Jf+j*u
      t = t + 1
WA
eRq2k;OB    End If
U$H0cm`4h$rh
y1k  End If
F@W7@&rYNNext RngQ+gE0A4z1~W$QW
SumCountVisible = t
BceO
\/]End Function

west_wolf 发布于2006-10-31 21:30:09: Excel2003高级VBA编程---第11章 VBA编程示例和技巧
实例六基础设置j7`6gh9N5N
小结：
4k4qH.T!E{q 本节主要论证如何在vba中进行Excel的基础设置？例如：
1、文本自动换行切换
{/{?$sW2[8ua"T4ZSelection.WrapText = Not Selection.WrapText8?Q0v2\/q9S6t
2、自动切换行号和列标
:ilI
K"zq2wActiveWindow.DisplayHeadings = Not ActiveWindow.DisplayHeadingsLbZ]#g1J&wL4x
3、自动切换网络线
*hV%WY^(V!`www.officefans.netActiveWindow.DisplayGridlines = Not ActiveWindow.DisplayGridlines|!Qil-M;W?&i
4、切换工作表标签
iZn[8i$za .DisplayWorkbookTabs = Not .DisplayWorkbookTabs
5、切换编辑栏9}[H#m:GG"H5^
.DisplayFormulaBar = Not .DisplayFormulaBar
6、切换状态栏
{4n
n-yniAMn~  .DisplayStatusBar = Not .DisplayStatusBar
N\c
A3y+@
h.jY7、切换任务栏窗口
HA8k.R~0_Y  .ShowWindowsInTaskbar = Not .ShowWindowsInTaskbar
在实际应用中，如果没有记住这些属性，可以录制一个宏进行相关方法、对象的学习。f\*uvCQy%G
具体代码如下：
];pX*y`D9M[eSub 自动换行切换()
j%mh,rC0Bo+Pi'切换换行格式，wraptext单元格格式设置文本为自动换行
,Q:vSn"JAc
_'只要格式设置为true或者false都可以利用not进行自动切换精英博客+k-L#JXBP
If TypeName(Selection) = "Range" Then
.t3l8]
Dh4j6{  Selection.WrapText = Not Selection.WrapText
i8|#Q[6Y
FEnd If
t1^%]+^Yc^3u精英博客End Sub
#n?3b)V
ISoSub 自动切换行号和列标()
7Mt(U1o*o*nE:~
}d~'利用activewindows的displayheadings属性切换行号和列标
a/i2BH5bY/}9W&I/MY1V2^精英博客ActiveWindow.DisplayHeadings = Not ActiveWindow.DisplayHeadings
End Sub
Sub 自动切换网络线()X1o%o},IFY{~6z_
ActiveWindow.DisplayGridlines = Not ActiveWindow.DisplayGridlines*M1qUa8R
End Sub
Sub 自动切换编辑栏等(),`6Kv3KGr;|I
With ActiveWindow
  .DisplayWorkbookTabs = Not .DisplayWorkbookTabs '切换工作表标签
s$o7sH;Ht`www.officefans.netEnd With
With Application
  .DisplayFormulaBar = Not .DisplayFormulaBar  '切换编辑栏www.officefans.netY.x]W
x
  .DisplayStatusBar = Not .DisplayStatusBar  '切换状态栏精英博客:pX:{-K2Je
ha
  .ShowWindowsInTaskbar = Not .ShowWindowsInTaskbar  '切换任务栏窗口
End With
+e6kN3d s3N?b3H.~www.officefans.net
End Sub

west_wolf 发布于2006-10-31 21:33:13: Excel2003高级VBA编程---第11章 VBA编程示例和技巧
实例七  实用函数
小结：

vU7?U5A^
ewww.officefans.net  本节通过实例介绍了一些比较实用的函数，包括查找某个文件是否存在、从包含路径的文件中提取文件名、判断单元格名称是否存在、判断某个工作表是否存在和某工作簿是否打开？
6E1rm^k5fqWE+bkwww.officefans.net1、Dir[(pathname[, attributes])]函数，返回一个 String，用以表示一个文件名、目录名或文件夹名称，它必须与指定的模式或文件属性、或磁盘卷标相匹配。如果文件不存在，则返回空值，运用此函数可以查找某路径下文件是否存在？
/i3OM2[;[$ANd~2s2、利用mid函数和application.pathseparator(返回路径分隔符\)从路径中提取文件名
5zeN\Xz3、单元格名称在vba中的运用
4、利用工作表或者工作簿属性结合err=0来判断工作表是否存在、工作簿是否打开？(_^p&l
VK3LA
Function SheetExists(Nname As String) As Boolean
/qwYy'ryt'在活动工作簿中查找某个工作表是否存在精英博客v;gi? i {
'这里主要定义一个对象变量，然后对对象变量赋值，如果没有发生错误，也就是ERR=0，那么SheetExists=true
:@i}l$dJ{Dim t As Object
p2bR(~]nOn Error Resume Next1~2~1NxNw$q4_2WF+W
Set t = ActiveWorkbook.Worksheets(Nname)
$Zh2i3^;d&{SheetExists = False
If Err = 0 Then SheetExists = True
6@+vI|*e;Zs8Jm$N-P精英博客End Functionw'w:h4cUy;s$B;B
具体代码如下：
Function FileExists(FileName As String) As Boolean"X0a1U/C$qs\*`f
Dim FlagString As String
Eo`4Ar+V*Eawww.officefans.net'利用dir函数判断某个文件是否存在，dir函数返回一个字符串，如果某个文件不存在，则返回空字符串www.officefans.net(f2AaN.`q5j2w
FlagString = Dir(FileName)
En$y+z!hmSIf FlagString = "" Then
2U*c8h.E@p7l FileExists = False/i
D;C]}4|6Js0iom
Else
Ui+vV"UY} FileExists = Truewww.officefans.netpFB],h
End Ifwww.officefans.netF
Q7^J]3_
End Function
9{ ~4f9\llc/sywww.officefans.netFunction FileNameOnly(FileName As String) As StringX+Q:A9}&J@*uQi
'从包含路径的文件名中提取文件，pathseparator返回路径分隔符"\"2\:YKb/G
Dim I As Integer
2O
l7^&s,{i:BDim ChrLen As IntegerjJv^vc0Ou*_
Dim FlagString As String
Dim t As Stringwww.officefans.net$a1E"y7t$n~+UM
ChrLen = VBA.Len(FileName)xb2M)d,s*]g8J mG
w4BW
For I = ChrLen To 1 Step -1
FlagString = VBA.Mid(FileName, I, 1)
r!ga8C
WU0]-\@h
If FlagString = Application.PathSeparator Then Exit For!j[~h"M'~.|

#yu#S8C7BoDwww.officefans.net 'If FlagString = "\" Then Exit For精英博客0Iyx0E/@0\:d
t = FlagString & t
9^4sK$USe+]%@GNext I
E+DfZ]cG7FB?FileNameOnly = t'Cd*IPY1f'i#k
End Function
P(`4Lkj"EFunction RangNameExist(Nname As String) As Boolean
l7vY,?
n8H'判断某个区域名称是否存在，Names集合/Name属性
Dim N As NamecULD8V{.X*mo ]Y/n
RangNameExist = False%H*\J!MCH)S
For Each N In ActiveWorkbook.Names精英博客8[s;b
RPp
If UCase(N.Name) = UCase(Nname) Then.a9Ox"}M;W$M&Y"U
   RangNameExist = True
!KnWHZ    Exit Function2f)O)O3uT$@{
End If
Next N
7VeMs&SO'|/OEnd Functionwww.officefans.net!pI;K^$EX8mt&zF
Function SheetExists(Nname As String) As Boolean
'在活动工作簿中查找某个工作表是否存在
[`jY7j&K!`.]精英博客'这里主要定义一个对象变量，然后对对象变量赋值，如果没有发生错误，也就是ERR=0，那么SheetExists=true
b3{*w Lx2P
a4PDim t As Object9p
c7C
]Kt
On Error Resume Next
!FF9j6f'c&ewE/eSet t = ActiveWorkbook.Worksheets(Nname)
)a/sW&{/B+F-u{7M@www.officefans.netSheetExists = False/{"~`J3H*{
If Err = 0 Then SheetExists = True
|-q?CRmi:D6}+dwww.officefans.netEnd Function
Function WorkbookIsOpen(WbName As String) As Boolean
Dim t As Object}/z'{pOA9I
'判断某工作簿是否打开
VNk6l:`(z%I精英博客On Error Resume Next
Set t = Workbooks(WbName)R0v5Q8fe+e:d:I
WorkbookIsOpen = False
M&xs JTO'H5E0kmh#VIf Err = 0 Then WorkbookIsOpen = Truev~j f.PtB_1]g
End Function

Sub 查找工作表是否存在()
;KlL1b:D6\OHDim t As String
]^|,` Fwww.officefans.net'函数调用，如果SheetExists定义为Private函数，则此处不能调用，因为他们不在一个模块中
t = InputBox("请输入需要查找的工作表名：", "查找工作表", ActiveWorkbook.ActiveSheet.Name)www.officefans.net
I`{
b,M8a6Z)J
If t = "" Then Exit Sub
1x }B]!d0xx*L:{If SheetExists(t) = True Then2}X.T2L6C(H;U,G
MsgBox t & "工作表找到"[6BMyF-`:b0n,T2qK
x
ActiveWorkbook.Worksheets(t).Select
Else
lU
hJaq"X*t6G
MsgBox t & "工作表没有找到"
End If+JT[]'YJ&D
r
{ o2YI
End Subwww.officefans.net6S5yp2T8`5M4D4E
Acp/}#A
[ 本帖最后由 west_wolf 于 2006-11-19 20:16 编辑 ]

west_wolf 发布于2006-11-15 22:06:41: 实例八快速插入若干行
f_t;bh/~Va'@"]cA
c;u-^e
   在实际工作中，有时需要插入很多行，通常是选定插入的行数，然后点击插入行。也可以使用快捷键alt+i+r。但当插入行如果超过100行，利用上述方法很不方便，此时可以利用下面代码完成。
8p#Ne@*~g;S/Rf._4e1?+v+|"XI~
Sub InsertMultipleRows()

t9m&m2fqaL`O'根据用户要求插入若干行
Dim InsertRows As Long ed&J'v u
i`J
Dim BeginRow As Longwww.officefans.net!Xf6COz9q/H6u
'如果没有选中的单元格或者单元格区域，则退出`O5{Hf7V!x`\;c
If LCase(TypeName(Selection)) <> "range" Then精英博客Z!^%R3PbZ6{
MsgBox "请选择需要插入的起始行或者第一行的单元格", vbInformation, "复杂插入行"
"yL,H3V^/N Exit SubcOO8u%OOI%Y)Y
End If
)W9LRam'返回选定单元格或者单元格区域的顶部行所在的行数，这里使用selection.cells(1).row更好理解www.officefans.net3s1cdg:c2C
BeginRow = Selection.Row
\G?+a8Z
Q'要求用户输入需要插入的行数
InsertRows = Val(InputBox("请输入要插入的行数：", "复杂插入行", 1))
'如果输入数据小于零，则退出
6a.cD6oE!u~If InsertRows <= 0 Then
j.|1c+M\q
G)_  MsgBox "对不起，输入有误，不能插入行！"
  Exit Sub
2D]FA"d6\EkEnd If精英博客z8Ct9y,^p9g5[
'插入行
]B#g:EcU
w G!D&OMwww.officefans.netRows(BeginRow & ":" & InsertRows + BeginRow - 1).Insert shift:=xlDown
8O+y!`PZ
r RhEnd Sub
vDd$z.W1S1I.Hb/vwww.officefans.net9Zr_Sfh"L
[ 本帖最后由 west_wolf 于 2006-11-19 20:18 编辑 ]

west_wolf 发布于2006-11-19 19:46:37: 实例九：工作表小技巧Pj ~:~!X8p;TEn
1、工作表汇总：在实际工作中，如果各工作表结构一样，需要将工作簿中各工作表汇总在一张工作表中，此时，运用下面代码：
:Y*}.J F?MHAJ6nSub TotalWs()
^)LUX!]?6LR8h'汇总工作表，任何时刻都可以执行本代码重新进行工作表汇总www.officefans.net0iU\V#w%`e1M-?
Dim Ws As Worksheet
%jN
]1[$]l~E2N'lDim IWs As IntegerW2I4MI_rf UU/X
Dim MaxRow As Long
On Error Resume Next
;t7p
OITC0O{www.officefans.net'检查汇总工作表是否存在，如果不存在，插入一个汇总工作表，并放在第一个位置
Set Ws = ThisWorkbook.Worksheets("汇总")
If Ws Is Nothing Then精英博客d
e;BwBH2bs
   Sheets(1).Activate精英博客)@$w%g8j6w]S}u
   Worksheets.Add
   ActiveSheet.Name = "汇总"
Else
O'pg0Y8@ef-L'如果汇总工作表存在，现将汇总工作表放在第一个位置，然后清除改工作表所有内容，重新汇总
[~Y
x n} Worksheets("汇总").Move before:=Sheets(1)
J'jF2as9y#G2En:? Worksheets("汇总").Cells.ClearContents

fzNQ@f4zwww.officefans.netEnd If"Plr K6Jm[^
'将工作表标题复制到汇总工作表中www.officefans.nettWZ2ZN0w5G
Sheets(2).Select"~H%MCS:G'u'U#x,b
Range("a1").EntireRow.Copy Destination:=Sheets(1).Range("a1")精英博客No.p0v#p%Sup
MaxRow = 2$J-^)i"wc `.j
For IWs = 2 To Worksheets.Count
lVxC-X'a;n '这里必须要激活工作表，而不是选定
Worksheets(IWs).Activate
Hn+U)z!N8H8RDwww.officefans.net Range("a1").CurrentRegion.Select

Y3t:~7JB8{;O#^ Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Copy Destination:=Worksheets(1).Cells(MaxRow, 1)
e Dh T&Zw8S MaxRow = Worksheets(1).Range("a65536").End(xlUp).Row + 1 z!y,Z;O0xV*zjxz+XYI
Next IWs
$A1[%X#gwp WMsgBox "工作表汇总完毕，请检验！", vbInformation, "工作表汇总"
-u,G$U:nmWorksheets(1).Activatewww.officefans.netc3tB/J(ohK5j
End Subhp%?"E2xf
2、隐藏取消隐藏工作表精英博客f,Vy'iLV2h*u
方法一：alt+o+h+h隐藏工作表或者点击格式-工作表-隐藏工作表
"bS)QV;N!a)O2a方法二：在vbe中设置工作表属性visible，如果选择-1则表示显示工作表，如果选择0则隐藏工作表，且该工作表不能在工作表窗口中取消隐藏。如果选择1则隐藏工作表，且只能在vbe中通过修改visible属性来取消隐藏工作表
-`
p8\]7{?FAH2M3、切换工作表
ctrl+pageup/ctrl+pagedown
c2O A(KK8Z5E4、通过工作表中某单元格值来排序工作表
`,G4F6~9?.mL2G~%`MSub WsSortCell()
+w(og%_R@$rR精英博客'通过工作表中单元格值进行排序
f$RYhz2SDgI+zConst irow = 1
8ZR2H(GH"aConst jcolumn = 1
q]s&Y9ODim i As Integer
Lri0OTUiDim j As Integer
Dim WsCount As Integer
WsCount = ThisWorkbook.Worksheets.Countwww.officefans.net[Ib0fLwE BY3n
'冒泡法排序
*bc
pmo `If WsCount = 1 Then Exit Sub
EM#C#s}(kb#b%@For i = 1 To WsCount - 1
  For j = i + 1 To WsCount
/~i5G.Y%TS7~}g    If Sheets(i).Cells(irow, jcolumn) > Sheets(j).Cells(irow, jcolumn) Then
      Sheets(j).Move before:=Sheets(i)
0P0p/jQe
}E [    End If精英博客K0_v][@J
  Next j
x1wxBF'EkNext i
End Sub
5、快速插入新的工作表
q;x$C?C.H5c#?pE5t插入工作表：shift+f11
删除工作表：alt+e+n
3l/B&i
kOC~5C6、利用cell函数返回工作表所在路径及名称www.officefans.net~&~
v5z(p:pd"vL
(1)=cell("filename") 含路径和文件名!o6Xo*wg5V Z*Xp&m
(2)仅返回工作表名
YuZ0y.gp5u =RIGHT(CELL("filename"),LEN(CELL("filename"))-FIND("]",CELL("filename")))精英博客D7F/P4A&\e
(3)返回工作簿名称
=MID(CELL("filename"),FIND("[",CELL("filename"))+1,FIND("]",CELL("filename"))-FIND("[",CELL("filename"))-1)
7、调整新增工作簿后工作表数量p%yS.Am4_
工具-选项-常规-工作簿中工作表数量
8、快速合并单元格，通过录制宏，为宏设置快捷键，以后直接通过快捷键来合并单元格。本实例主要是验证为宏添加快捷键，以方便快速执行宏Xcut6Na*I?O
为宏设置快捷键步骤如下：
工具-宏-选项-设置快捷键（当然要选择已经设计好的宏）

west_wolf 发布于2006-11-21 09:09:02: 实例十工作表标签
_cQ
{(z-N
q9] f1、动态命名工作表，可以在工作表中输入工作表名，然后利用vba来读取单元格命名工作表[QD+PN3|%a'fV1^
精英博客HwkM1x.X
E
Sub DynamicWsName()
%wT fg~i精英博客Dim FlagString As String,HXP7O.eQS/H$_
Dim Ws As Worksheetd5Co)D1Rfe
YW
Dim t As Integer
#SC%w)N~t.awww.officefans.netOn Error Resume Next精英博客5H]Vcv.^
Set Ws = Worksheets("定义工作表名")9is o;Y+nf
t = WsCount
If Ws Is Nothing Then
7VHrO)a?qwww.officefans.net Worksheets.Add before:=Worksheets(1)精英博客*c7a/q^n"^
ActiveSheet.Name = "定义工作表名"
H3wmZZ"C"v
B)fwww.officefans.net Range("a1:b1") = Array("序号", "工作表名")
h`F%^%{.t精英博客 Range("a2").Formula = "=if(row(a1)<=" & t & ",row(a1),0)"
Range("a2").AutoFill Destination:=Range("A2:A14"), Type:=xlFillDefault
/NG~cv.d(i6|www.officefans.net MsgBox "请输入工作表名"
2S{uX
f&G"cf Range("b2").Select&@+`tQMtD
Exit Sub
fb"I4kArEnd If
tna)F"R%Q4@[y
gcwww.officefans.netWs.Activate
p
MJ4y)Z`y?Ci = 2X|^f0R'~MqF\?
!Im,SEdhm
Do While Ws.Cells(i, 1) <> 0
Worksheets(i).Activateoem%E)n8_{3o"l
If Len(Ws.Cells(i, 2)) <> 0 Then

"KW_{A|$I_|g    ActiveSheet.Name = Ws.Cells(i, 2)e
e bo9R'q$zO
End If

{H7AE.kS i = i + 1
|2S+S})gLoop){}}b$RQe3\
Worksheets(1).Activatewww.officefans.net;g#kiy+u"p5gx

End Sub
A D1w4sFu dxFunction WsCount()
'统计工作表的数量(^}w%`?d!F
Application.Volatile
+N2tcF`{@J#W5LLWsCount = ThisWorkbook.Worksheets.Count @$Z(p{^3C
End Function
"H3u7t3J6S6D精英博客
:Zy~#GKt3sU2、调整工作表标签字体大小，在Excel中不能直接调整工作表标签字体的大小，此时可以在windows桌面上右键-属性-外观-高级-项目-共具提示-字体来设置
Q`BU'_www.officefans.net
3、新增工作表，表名为yyyy-mm-dd 第n周，其中：日期为每一周的第一天，也就是星期日，第一天和最后一天除外。第一天为某年的第一天，最后一天为12月31日 udL}chKB
gRO)W)B8BWw
Sub YearWeek()
'gi@p\(}?精英博客'下面的代码增加52个工作表，且每个工作表名为第n周的第一天（星期天）日期www.officefans.netFsU-Ii

Dim i As Integer精英博客:r3lWrAB*]
Dim Ws As Worksheet
'{0D|'zkDim InYear As Integer4zD~H1`%r
@
Dim Marr(1 To 7, 1 To 2)
o\5Mo8@Z7dDim Arr As Variantwww.officefans.net!A.|Ce A:O-E}
Dim Msg As String
N(T%m} I&mWnDim Day01 As Date

ntO'@7u%gCe3v;twww.officefans.net'如果工作表存在，则不添加
o#z9h*p8]awww.officefans.netOn Error Resume Next
*DBO*G5Ssp,VnF@精英博客'数字转换
Arr = Array("一", "二", "三", "四", "五", "六", "日")

c?M?b
LW$H8eApplication.ScreenUpdating = False
J&V]"XX精英博客Worksheets(1).Cells(1).ClearContents
$`Qfq
P/o
j3twww.officefans.netFor i = 1 To 7www.officefans.net.t,J
N%\
I/n2YiH
Marr(i, 1) = iwww.officefans.netZpcG4}G3cY@
Marr(i, 2) = Arr(i - 1)
w)x4~~].g(xTNext i精英博客/^o]7v\D-SH
InYear = Val(InputBox("请输入年", "增加本年周工作表", Year(Date)))
\^JbeWorksheets.Add After:=Worksheets(Worksheets.Count), Count:=(52 - Worksheets.Count)
i = 0oC/g$G*p%O}"CG*a
date01 = DateSerial(InYear, 1, 1)Zc/mPM2K6i#[
For Each Ws In ThisWorkbook.Worksheets
i = i + 1
7Q`4K:_(l`G$pk精英博客 If i = 1 Then
   Ws.Name = Format(date01, "yyyy-mm-dd") & " 第" & i & "周"
nk"L*Zu:k'TVP Else~)D[R5e
   If i = 2 Then精英博客[{#dS9Y}D
      Ws.Name = Format(date01 + 7 - Weekday(date01) + 1, "yyyy-mm-dd") & " 第" & i & "周"i(f4Y7F6~
x
s0F2MQ
      t = date01 + 7 - Weekday(date01) + 1
6]Ax3CY9Bxk    Else
{9Tm U-{yZG精英博客       t = t + 7精英博客!\e_+V4{
D$e;z7|
      Ws.Name = Format(t, "yyyy-mm-dd") & " 第" & i & "周"'IC3T$y}^z5j;p'\O8w
   End If
'O*x@\h精英博客 End If
+])QYn`CT8v/N精英博客Next Ws
{-_3J,nNO3y?-{Worksheets(1).Cells(1, 1) = InYear & "年1月1日为：星期" &Application.WorksheetFunction.VLookup(Weekday(DateSerial(InYear, 1, 1))+ 1, Marr, 2, False)
P4|
gX;K,f%^:jwww.officefans.netApplication.ScreenUpdating = True
TBi"G2^#[+Y"L精英博客End Sub

7Ei*lT3UO*K{www.officefans.net4、快速复制工作表
;X)iVL3N.l Alt+E+M调用移动复制工作表对话框，如果想复制工作表则选择副本，否则不选择；5o9G!S%Q-\
t4z2Z
如果在同一工作簿中快速复制工作表，则可以利用ctrl和鼠标复制工作表
.G\.r? eg1JS!P
5、快速选择工作表
W wq;i
?o(1)直接点击工作表标签
k-H+NNA5K(2)在最左边工作表标签拐角处右键，然后选择工作表
\9?7N z1R2] P5L(3)通过下面的代码将各工作表名称放置在目录工作表中，并建立超级链接，直接在目录中选择工作表
Sub List()www.officefans.netD-gN`G5v
'产生目录r
aTYLLXz
Dim Ws As Worksheet
$h%pdAOVDim WsActive As Worksheet精英博客R2M s't'I"g8k4j
Dim Ml As Worksheet7k^S:Lk5p
'当工作表不存在时，会产生一个错误，此时忽略错误，继续执行下面的语句，即ml为nothing
aD5C2n @On Error Resume Next
Application.ScreenUpdating = FalseC(O-w.c&l4S
Application.DisplayAlerts = False
Set Ml = Worksheets("目录")www.officefans.net%n+T&OO+[b/^1r
If Not (Ml Is Nothing) Then
/t"~p$xQ]{精英博客 Ml.Delete
`m:Y2z"k精英博客End If
k'@d0K7tm0xoYWorksheets.Add before:=Worksheets(1).Q5^Pwa
Set WsActive = ActiveSheet
WsActive.Name = "目录";^]z7L@
W2~(P8K^+~t
Range("a1") = "目录"ht,q4S3Uwfu
Range("a1").Font.Bold = Trueb%PU:@+U.B[d
Range("a1:d1").Mergel6@F/N;kR?e/Y
d
Range("a2") = "序号"'WP\v y)X(?1l]
Range("b2") = "工作表名称"

*x,^ h*bO1E
_'twww.officefans.neti = 20[kg/VrH U4f
For Each Ws In Worksheets
#z'Qn6C.aNuwww.officefans.net
^0DSJ?精英博客 If Ws.Name <> ActiveSheet.Name Thenwww.officefans.net8^0^(m
Wmj
   i = i + 1www.officefans.net[hn#dv!A-d0C8m
   Cells(i, 1) = i - 2
{j^-}Kif s    Cells(i, 2) = Ws.NameEA&Z3T/])DaK

](I-i\'a:c-gN
]+x精英博客    '建立超级链接，注意超级链接的书写方式 '2005-12-5 星期一'!A1
g+x@6d&CR    ActiveSheet.Hyperlinks.Add Anchor:=Worksheets("目录").Cells(i, 2), Address:="", SubAddress:= _/@2^!zAs R
            "'" & Ws.Name & "'!a1", TextToDisplay:=Ws.Name
B"_va }:^W-hM    www.officefans.net ~$syA,|6c*J
End If
G^#e"`O9Q6Z
Next Ws
vb0lb8b
y精英博客With Cells.Font
  .Size = 9
  .Underline = xlUnderlineStyleNone9SxxQeP
End With
jvtx&m
wM?1gRange("a1").Font.Size = 14
精英博客2L(cwLO:M
oF0si
Cells.Columns("a:iv").AutoFit
+D[/OFw1hD
Application.DisplayAlerts = True
Application.ScreenUpdating = True(ADg&~TC
End Sub
%m-m~+o@
)srz'h l a(i6、返回工作表名
@i8O-g8q8d5[q0]8l `方法一：利用excel宏函数cell("filename")8Sc
?9F d*k4ngP!?v
=RIGHT(CELL("filename"),LEN(CELL("filename"))-FIND("]",CELL("filename")))精英博客&q]9F8zY|j5l
方法二：在vba中定义函数
Function WsName()y8rT"DN/}
WsName = ActiveSheet.Name
End Function

/dQA L'Q2P1{7、根据年月增加工作表（工作表数量为某年某月的天数）Sh^,H!ZK#i:w%c
Private Sub CommandButton1_Click()
F S(zu+[.h'根据输入的年份和月份新增工作表，工作表名称'yyyy-mm-dd 星期几"www.officefans.net2[Q`(A&xv8^5|
'直接在工作表窗口中按ctrl+w执行本代码
/Hqj-RND(x,Q3j1K
d3O8NO$KlDim MDay As Integer
Dim MYear As Integerwww.officefans.netXc.hK@F6w
W
Dim MMonth As Integer
kgsPSu1qwww.officefans.netDim Ws As Worksheet
]9nRc"p;~2kRQX8c精英博客Dim WsCount As Integer精英博客)Y)rWgO0Q/j
Dim MDate As Date+B2tQ@
Fn0jlx8d
Dim i As Integer
Dim Marr As Variant
*?2o{"}^%k'tN精英博客Dim Arr()
Dim t As String |s5M,\,DzO
Application.DisplayAlerts = False
s+b5~nLz1h:T+Cxa#`@pApplication.ScreenUpdating = False
'删除源工作表精英博客"R3pn-bbf
n)m
精英博客rb"XgQ.[d['n{
For Each Ws In Worksheets
$Qr6iy
C
N2W精英博客 If Ws.Name <> ActiveSheet.Name Then Ws.DeleteU$c6M3Y iL
Next Ws
vA$S
k-tPw}Xwww.officefans.netActiveSheet.Name = "根据月份插入新工作表"
?d+f,Zy+I\www.officefans.net
X b~)g.D4rMYear = Val(UserForm1.txtyear)(_ uX2rG|8_
MMonth = Val(UserForm1.txtmonth)t }'lqZwF
If MYear = 0 Or MMonth = 0 Or MMonth < 1 Or MMonth > 12 ThenJ(C&]|lL
MsgBox "年和月份不能为空！", vbInformation, "年月份校验"