[接龙...]部分程序代码注释，目录更新20051222

学习分享

看了这些贴,才知道自己的EXCEL用的是多么的差啊!

lgcmeli

真是很经典哪.

gerrily

以下是引用Long_III在2005-9-9 15:34:37的发言：

35、把工作表里的数据转到记事本里。（刚好与上一个例子相反），这里比较了打开方式output和append的区别，具体请看代码：

Private Sub CommandButton1_Click() '以output打开方式 Dim i%, irow% Dim S As String Const FullName As String = "E:\Hjsong.txt" '定义一个常量，确定要保存的位置，或打开文件的位置

Open FullName For Output As #1 '以读写方式打开文件，每次写内容都会覆盖原先的内容 '参考帮助，fullname为文件全名，output为读写方式，Append为追加读写形式

irow = [a65536].End(xlUp).Row '工作表里最后一列 For i = 1 To irow '每行的数据都写入txt文件中 S = Cells(i, 1) & " ++ " & Cells(i, 2) & " ++ " & Cells(i, 3) '链接三列的数据 Print #1, S '把数据写到文本文件里 Next i

Close #1 '关闭文件 MsgBox "数据已导入文本"

End Sub

Sub hjs() '以Append打开方式，单独在VBE里运行即可 Dim i%, irow% Dim S As String Const FullName As String = "E:\Hjsong.txt" '定义一个常量，确定要保存的位置，或打开文件的位置

Open FullName For Append As #1 '以读写方式打开文件，每次写内容都会覆盖原先的内容 '参考帮助，fullname为文件全名，output为读写方式，Append为追加读写形式

irow = [a65536].End(xlUp).Row '工作表里最后一列 For i = 1 To irow '每行的数据都写入txt文件中 S = Cells(i, 1) & " ++ " & Cells(i, 2) & " ++ " & Cells(i, 3) '链接三列的数据 Print #1, S '把数据写到文本文件里 Next i

Close #1 MsgBox "数据已导入文本" End Sub

龙三老师，能不能给个格式输出文本文件的例子，谢谢啦！

Long_III

54、自定义函数的可选参数的设置和工作表页码的计算

不知道代码算不算好，反正能实现目的，有兴趣的朋友，可以优化一下，与大家分享一下。对于可选参数，如下所说：

Private Function PAGE(a As Range, Optional b As Boolean = False) As String '可选参数默认一定要赋值 '在这里默认为false，就是输入公式时，如果输入=page(L20)，则在代码运行时默认为b为false '如果输入=page(L20,1)，则b的值按1来运行

WqW7k0Hy.rar (16.02 KB, 下载次数: 126)

2005-10-14 15:43 上传

点击文件名下载附件

关于此问题有一个更完善的解决方法，请看帖子http://club.excelhome.net/viewthread.php?tid=127884 32楼

[此贴子已经被作者于2005-10-17 8:42:41编辑过]

Long_III

关于自定义函数的可选参数问题，上贴说的不是很准确，经过搜索，找了两个很好的例子，大家可以看看：

1、大头斑竹的，★可有可无的参数（第一次知道ismissing，上面的代码就是因为不知道这个，试验了好久） Function test(Optional x, Optional y) Dim temp If IsMissing(x) Then temp = "没有x" Else temp = "x输入了:" & x End If If IsMissing(y) Then temp = temp & "没有y" Else temp = temp & "y输入了:" & y End If test = temp End Function

2、wshzw兄的：此自定义函数有两个可选参数，为可选参数设定了默认值: Function Test_2(Optional x = 1, Optional y = 10) As Double Dim temp As Double If IsNumeric(x) Then temp = x * y End If Test_2 = temp End Function

原处链接为：http://office.9zp.com/dispbbs.as ... ;ID=3867&page=1，IsMissing函数，返回 Boolean 值，指出一个可选的 Variant 参数是否已经传递给过程。

[此贴子已经被作者于2005-10-14 16:19:01编辑过]

yigepure

代码再简化一点

Sub hjs() '直接运行可以求到，当前单元格的位置所在的页数和总页数 Dim P As HPageBreak, Q As VPageBreak Dim m%, n%, x&, y&, x1%, y1% Dim arr(), rng As Range, Sht As Worksheet

Application.ScreenUpdating = False Set rng = ActiveCell '设置rng为当前单元格 Set Sht = ActiveSheet If Application.Intersect(rng, Sht.UsedRange) Is Nothing Then MsgBox "当前单元格不在数据区域内，无页码": Exit Sub

x = rng.Row: y = rng.Column 'x为行，y为列

For Each P In Me.HPageBreaks m = m + 1 If x < P.Location.Row Then x1 = m Exit For End If Next

For Each Q In Me.VPageBreaks n = n + 1 If y < Q.Location.Column Then y1 = n Exit For End If Next t1 = Sht.HPageBreaks.Count + 1 t2 = Sht.VPageBreaks.Count + 1 If x1 = 0 Then x1 = t1 If y1 = 0 Then y1 = t2

imax = t1 * t2 ReDim arr(1 To t1, 1 To t2) k = 1 If Me.PageSetup.Order = 1 Then '先列后行，计算页码的顺序 For j = 1 To t2 For i = 1 To t1 arr(i, j) = k k = k + 1 Next Next Else For i = 1 To t1 For j = 1 To t2 arr(i, j) = k k = k + 1 Next Next End If

MsgBox "第" & arr(x1, y1) & "页,共" & imax & "页" Application.ScreenUpdating = True End Sub

SZ790901

那位朋友能帮我注释下以下内容,谢谢啦~

Private Sub Workbook_Open() If Date > #10/1/2005# Then If Date < #1/1/2006# Then Yn = MsgBox("本系统的有效期还有 " & #12/31/2005# - Date & " 天。", vbExclamation) Else ThisWorkbook.Close SaveChanges:=False End End If End If Sheet8.Activate Evnt False If Sheet8.Range("K1") <> ThisWorkbook.Name Then _ Sheet8.Range("K1") = ThisWorkbook.Name If Sheet8.Range("K2") <> "" Then UserForm2.Show

Evnt True ThisWorkbook.Close SaveChanges:=False End End If Sheet3.Activate Sheet3_Clear Evnt True

End Sub

Long_III

55、二维数组的动态增加及错误值的判断。例子摘自taller斑竹给别人的答题，代码简洁且经典，学习！

wGzWKtA6.rar (221.29 KB, 下载次数: 182)

2005-10-17 12:29 上传

点击文件名下载附件
[接龙...]部分程序代码注释，供一些入门选手学习！

如果注释有什么地方不妥的话，请指正！代码

Private Sub CommandButton1_Click() Dim mylist As New Collection '定义一个新的集合 Dim n As Integer Dim data '从单元格里取数的数组 Dim price() '定义一个取产品和单价的数组

Application.ScreenUpdating = False '关闭屏幕更新，加快代码运行速度 data = Range([b2], [c65536].End(xlUp)).Value '用数组取单元格的值 n = 0 On Error Resume Next '如果产生错误，将直接执行下一句 For i = UBound(data, 1) To 1 Step -1 '从最后一个数到第一个 mylist.Add data(i, 1), data(i, 1) '集合里增加数据 If Err.Number = 0 Then '如果运行正常，则（正常运行的时候，number就是0，产出错误时（也就是集合增加重复数据的时候）就大于0） ReDim Preserve price(1, n) '重新定义数组大小时，“如果使用了 Preserve 关键字，就只能重定义数组最末维的大小， '且根本不能改变维数的数目。例如，如果数组就是一维的，则可以重定义该维的大小，因为它是最末维，也是仅有的一维。 '不过，如果数组是二维或更多维时，则只有改变其最末维才能同时仍保留数组中的内容。” price(0, n) = data(i, 1) price(1, n) = data(i, 2) '给动态的二维数组赋值 n = n + 1 End If Err.Clear '清除原先记录的错误 Next On Error GoTo 0 '以后产生错误时将继续报错 Sheet2.Cells.ClearContents '清除sheet2里面的所有内容 Sheet2.[a1].Resize(UBound(price(), 2) + 1, 2) = Application.Transpose(price) '把二维数组的值赋给单元格 Sheet2.Select Application.ScreenUpdating = True '恢复系统设置 MsgBox "Ready"

End Sub

谢谢lipton兄的提醒，原贴在http://club.excelhome.net/viewthread.php?tid=127801

[此贴子已经被作者于2005-10-17 12:40:29编辑过]

XUDAN511

227楼的要拿实际例子过来，这个前面的感觉是在设定有效期

lipton

回错贴了，不好意思，希望不要当我灌水

[此贴子已经被作者于2005-10-17 12:40:34编辑过]