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

Long_III · 发表于 2005-9-7 09:25

33、显示当前表里自动筛选的所有信息！在一段英文例子里看到的，大致修改了一下做了一个注释，代码如下：

Private Sub CommandButton1_Click() '找出当前筛选的所有信息 Dim oAF As AutoFilter, oFlt As Filter Dim sField$, sCrit1$, sCrit2$ Dim sMsg$, i%

If ActiveSheet.AutoFilterMode = False Then '如果当前工作表种不存在筛选，则退出 MsgBox "当前表没有筛选！": Exit Sub End If

Set oAF = ActiveSheet.AutoFilter '创建一个自动筛选的对象

For i = 1 To oAF.Filters.Count 'Filter，筛选对象的集合，这个集合包含自动筛选区域中的所有筛选，从第一列到最后一列循环 sField = oAF.Range.Cells(1, i).Value '记录筛选种每一列的第一行的单元格内容 'oAF.Range表示筛选的全范围，如这里就是A2：D21 Set oFlt = oAF.Filters(i) '设置每一列筛选的filter对象 If oFlt.On Then '假如存在筛选的话 sMsg = sMsg & vbCrLf & sField & oFlt.Criteria1 '得到第一个筛选条件 'vbCrLf常量表示：回车符与换行符结合Chr(13) + Chr(10) Select Case oFlt.Operator '如果存在自定义筛选，根据操作判断 Case xlAnd sMsg = sMsg & " And " & sField & oFlt.Criteria2 '判断第二个筛选是and还是or，并链接第二个条件 Case xlOr sMsg = sMsg & " Or " & sField & oFlt.Criteria2 Case xlBottom10Items sMsg = sMsg & " (bottom 10 items)" '这些看看筛选里面的前十项等 Case xlBottom10Percent sMsg = sMsg & " (bottom 10%)" Case xlTop10Items sMsg = sMsg & " (top 10 items)" Case xlTop10Percent sMsg = sMsg & " (top 10%)" End Select End If Next

If sMsg = "" Then '表示没有筛选 sMsg = "筛选范围是：" & oAF.Range.Address(0, 0) & "没有自定义筛选" Else '表示有筛选 sMsg = "筛选范围是：" & oAF.Range.Address(0, 0) & Chr(13) & vbCrLf & "筛选条件是：" & sMsg End If

MsgBox sMsg '在对话框里显示 End Sub

3PPnTA5f.rar (12.64 KB, 下载次数: 228)

fokus · 发表于 2005-9-8 18:52

好东西，学的有的吃力

Long_III · 发表于 2005-9-9 15:05

34、读取文本文件到工作表里。两种方法，两个示例，比较着看。早先大师的代码，忘了出处，忘见谅。代码如下 W0iVLe86.rar (14.01 KB, 下载次数: 274)

Sub OneTxt() '打开一个txt文件 Dim Filename As Variant, extLine&, mArr() As String Dim i%, j%

ChDir ThisWorkbook.Path Filename = Application.GetOpenFilename("Text Files (*.txt), *.txt", , "请选取档案", , MultiSelect:=False) If Filename = False Then Exit Sub '最后一个选项MultiSelect等于false表示只能选择一个文件，如下面的等于true可以选择多个文件 '选择多个文件的时候是一个数组，需要循环打开，一个的时候就是字符串 j = 1 With Worksheets("sheet1") .Cells.ClearContents '删除第一个表的内容 Open Filename For Input As #1 ' 以只读的方式打开文件，参考open方法的帮助 Do While Not EOF(1) ' 循环至文件尾。 Line Input #1, TextLine ' 读入一行数据并将其赋予某变量 mArr = Split(TextLine, " ") '按空格分开这个字符，循环赋值给单元格 For i = 0 To UBound(mArr) .Cells(j, i + 2) = mArr(i) '此处参考split函数的帮助 Next i .Cells(j, 1) = Dir(Filename) '等于文件名 j = j + 1 Loop Close #1 ' 关闭文件。 End With End Sub

Sub TwoTxt() '打开多个txt文件 Dim txt As Object, j%, i%, m% Dim TextLine As String Dim Filename As Variant

ChDir ThisWorkbook.Path Filename = Application.GetOpenFilename("Text Files (*.txt), *.txt", , "请选取档案", , MultiSelect:=True) If Not IsArray(Filename) Then Exit Sub

Delete For Each fn In Filename '在整个选择的范围内循环 m = m + 1 j = 1 Set FSO = CreateObject("Scripting.FileSystemObject") Set txt = FSO.OpenTextFile(fn, 1, False) '打开文件，以只读方式打开 Do Until txt.AtEndOfStream '直到最后一个 TextLine = txt.ReadLine '与上例中的一样，读入一行数据并将其赋予某变量 mArr = Split(TextLine, " ") '按空格分开这个字符，循环赋值给单元格 For i = 0 To UBound(mArr) Worksheets(m).Cells(j, i + 2) = mArr(i) Next i Worksheets(m).Cells(j, 1) = Dir(fn) '等于文件名 j = j + 1 Loop txt.Close '关闭文件 Set txt = Nothing Next End Sub

Long_III · 发表于 2005-9-9 15:34

35、把工作表里的数据转到记事本里。（刚好与上一个例子相反），这里比较了打开方式output和append的区别，具体请看代码： WRGXeWVT.rar (10.26 KB, 下载次数: 337)

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 · 发表于 2005-9-9 17:17

36、工作表从小到大排序（简单的冒泡排序法）。 TJF6hy1q.rar (9.43 KB, 下载次数: 188)

要理解这个过程，得多试验几次，慢慢体会

Sub Sorting() '冒泡排序法 Dim sCount As Integer, i As Integer, j As Integer Application.ScreenUpdating = False sCount = Worksheets.Count If sCount = 1 Then Exit Sub For i = 1 To sCount - 1 For j = i + 1 To sCount '这个过程的意思以一个例子来看 If Worksheets(j).Name < Worksheets(i).Name Then Worksheets(j).Move before:=Worksheets(i) End If Next j 'if i = 1 then End '如果要看第一轮移动的结果，可以在这里加一个end试试 Next i Sheet1.Select End Sub

'假如，工作表的顺序是Sheet6、Sheet8、Sheet4、Sheet3、Sheet1、Sheet7、Sheet2、Sheet5 '当i＝ 1 的时候，即i为sheet6，后面的工作表从j＝i+1到所有的循环，一个一个比较 '8大于6，所以不动，接着4小于6，则4就移动到6的前面，此时4就是第一个工作表了，接着循环，3小于4，则3移动 '到第一个了，此时第一个工作表就是3，接着循环，1小于3，则1移动到3的前面了，再循环时，1是最小的了，故其他 '工作表不会移动，～经过第一轮的移动，会把最小的移动到最前面，后面的循环类似，直到最后一个

zw1028 · 发表于 2005-9-10 09:46

怎么又到后面了，为了让更多的人看到，学到，顶！顶！顶！

嫦娥仙子 · 发表于 2005-9-11 16:12

很幸运能跟Long_III学习！

,虽然我来迟啦！

yanjun_lyg · 发表于 2005-9-11 18:48

强烈支持，感谢版主和各位热心高手！

Long_III · 发表于 2005-9-12 13:14

37、irank函数，排序中忽略重复数值的自定义函数。思路为：用集合取出所有不重复值，然后对不重复值按大到小排序，然后找单元格在里面的位置，代码如下： zbKFpiBw.rar (8.16 KB, 下载次数: 200)

Function irank(rng As Range, rng1 As Range) Dim h As New Collection '定义成一个新的集合 Dim i%, M% Dim c As Range Dim arr(), arr1() '定义数组，如果刚开始不确定大小，就定义成空数组

Application.Volatile '标记为易失性函数，每次单元格变动后自定义函数重新计算 On Error Resume Next '用一个集合，选出所有不重复的数，错误处理可以忽略集合中增加重复数据 For Each c In rng1 h.Add c, CStr(c) Next Err.Clear '清除原先产生的错误参数 On Error GoTo line1 '之后产生错误的时候，自动跳转到line1行

M = h.Count '设置M等于集合的总数 ReDim arr(1 To M) '重新定义数组的大小 For i = 1 To M '把不重复的数都赋值给数组arr arr(i) = h(i) Next

ReDim arr1(1 To M) '对之前的数组进行排序，得到新数组arr1 For i = 1 To M arr1(i) = Application.WorksheetFunction.Large(arr, i) '调用了工作表函数large Next

irank = Application.WorksheetFunction.Match(rng, arr1, 0) '查找单元格对应的位置，调用工作表函数match Exit Function line1: irank = "Err" End Function

Long_III · 发表于 2005-9-12 13:27

38、工作表按条件插入分页符！例子摘自office精英俱乐部，代码进行了修改及注释 In3djSQL.rar (37.46 KB, 下载次数: 199)

Private Sub 分页_Click() Dim i%, j%, k% Dim arr, aa

aa = Timer '记录程序开始运行时的时间 Application.ScreenUpdating = False '关闭屏幕更新 With Sheet1 .ResetAllPageBreaks '重新设置分页符 .PageSetup.PrintArea = "" '设置打印区间为空 k = .Range("a65536").End(xlUp).Row 'a列的最后一行 arr = .Range("a1:a" & k) '把a列赋值给数组arr

For i = 2 To k '在数组里循环 If Left(arr(i, 1), 4) = "会计科目" Or i - j > 46 Then '当当前单元格含有会计科目时或连续46次没有插入分页符时 .HPageBreaks.Add Before:=.Cells(i, 1) '插入分页符在单元格前 j = i '记下此时的i的值 End If Next End With Application.ScreenUpdating = True MsgBox "程序共运行了" & Format(Timer - aa, "0.00") & "秒" '记录程序运行的总时间，timer函数表示当前时间 End Sub

		自动登录	找回密码
密码			免费注册

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

评分