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

Long_III

28、给选择的文件夹里的所有excel加密码、改密码（不包含工作表密码）。程序过程：1、选择一个要加密的文件夹，2、输入新密码，3、判断里面的excel是否含有密码，如果有密码，则需要输入原先的密码，如果没有，直接打开，4、修改密码，关闭工作簿

注意，此文件夹下的excel如果有密码，只能有一个统一的密码（或者为空也行），如果一个工作簿一个密码的话，只会修改一个，而且会改的很乱，这种情况不建议使用本程序，欢迎测试。里面采用了emily斑竹的 密碼一般的 Inputbox ，里面需要引用，建议先去原贴看看！其实也可以直接用inputbox做。

ckw9c39c.rar (26.42 KB, 下载次数: 244)

2005-9-1 12:40 上传

点击文件名下载附件

由于里面的代码较长，就不附了，里面对我写的代码有详细的注释，emily斑竹的俺还不会呢。

－－－－－－－－－－－－－

a、 再给个简单的数组例子，是把单元格里的公式全部写在VBA里，用数组速度会快一点，那里有详细的代码说明,http://club.excelhome.net/viewth ... xtra=&page=1#115419 7楼

b、 对于能用数组处理的，尽量都用吧，速度快乐谁不喜欢啊,http://club.excelhome.net/viewthread.php?tid=119678

c、 把所有的data类型的文件转换成excel文件，主要利用了录制导入数据的宏，然后逐一复制，粘贴，另存，里面有详细的注释，欢迎查看，http://club.excelhome.net/viewthread.php?tid=119564 8F

[此贴子已经被作者于2005-9-2 13:20:22编辑过]

dslgz

26、简单的生成目录代码！没有什么技巧，唯一需要了解的就是hyperlinks方法，在帮助里有详细的介绍

Private Sub CommandButton1_Click() '建立一个超链接 Dim sht As Worksheet Dim rng As Range Columns(2).ClearContents '清除B列的内容 Set rng = [b2] '设置B2为目录的起始位置 For Each sht In Sheets '在每个表里循环 If sht.Name <> Me.Name Then '假如表的名称不等于当前表（因为代码在目录下，故Me就是表示当前表）名称 rng = sht.Name '给单元格赋值，等于表名 Me.Hyperlinks.Add rng, "", sht.Name & "!A1" '在当前表建立一个超链接，链接到另外一个表的A1 sht.Hyperlinks.Add sht.[a1], "", Me.Name & "!" & rng.Address(0, 0) '在另外已表里的A1建立超连接，返回到当前表本单元格里 Set rng = rng.Offset(1, 0) '单元格向下移动一格 End If Next End Sub

Private Sub CommandButton2_Click() '删除链接内容 Dim sht As Worksheet Dim p As Hyperlink For Each sht In Sheets '在每个表里循环 For Each p In sht.Hyperlinks '在所有的链接里循环 sht.Range(p.Range.Address).Clear '删除链接单元格的内容和格式 'p.Delete '单纯删除超链接，不删内容，这句不能与上句同时使用 Next Next End Sub

谢谢，实用很强。我正好需要。

[此贴子已经被作者于2005-9-1 12:56:22编辑过]

hgc

谢谢！虽然我这新手有些还看不懂，但都悉数收藏。

bmdsjxyw

温暖的Excelhome,

温暖的帖子！

xing

这种方式不错,为我们这些初学者提供了方便,谢谢各位,

zw1028

里面又有好多新东西，为让更多的朋友看到学到，顶一下呀！

prince

这个函数不是我的作品，我只是将之注释一遍

Function colorsum(y As Range, rng, z As Integer) ' 传递参数为3个，第一个是取样单元格，第二个是需要合计的单元格区域，第三个是相对偏移列。 Application.Volatile '将用户自定义函数标记为易失性函数。

Dim c As Double Dim x As Range colorsum = 0 For Each x In rng '遍历需要合计的单元格区域 If x.Interior.ColorIndex = y.Interior.ColorIndex Then '当前遍历到的单元格如果符合颜色要求 c = x.Offset(0, z).Value '将相对当前单元格偏移0行，Z列的值存入临时变量C Else 否则将C清0 c = 0 End If colorsum = colorsum + c '将当前临时变量的值存入函数 Next x End Function Function colorcount(y As Range, rng) Application.Volatile Dim c As Double Dim x As Range For Each x In rng If x.Interior.ColorIndex = y.Interior.ColorIndex Then c = 1 Else c = 0 End If colorcount = colorcount + c Next x End Function '与Colorsum类似

[此贴子已经被作者于2005-9-3 13:42:07编辑过]

Long_III

29、判断一个文件夹是否存在！ xqaGVSoL.rar (12.67 KB, 下载次数: 195)

2005-9-5 13:33 上传

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

第一种方法可以说是帮助里的内容，大家可以看看。代码如下：

Private Sub CommandButton1_Click() Dim Myname Dim s$ Dim Mypath$

'Mypath = "E:\工具类\" ' 指定路径，修改成你自己的哦 Mypath = [b7].Value

Myname = Dir(Mypath, vbDirectory) ' 找寻第一项。 If Myname = "" Then MsgBox "不存在这个目录哦" Exit Sub Else Do While Myname <> "" ' 开始循环。 ' 跳过当前的目录及上层目录。 If Myname <> "." And Myname <> ".." Then ' 使用位比较来确定 MyName 代表一目录。 If (GetAttr(Mypath & Myname) And vbDirectory) = vbDirectory Then s = s & "-" & Myname & Chr(13) End If End If Myname = Dir ' 查找下一个目录。 Loop If s = "" Then MsgBox "存在，但里面不包含子文件夹" Else MsgBox "存在，里面包含的子文件夹有：" & Chr(13) & s End If End If End Sub

Private Sub CommandButton2_Click() Dim Mypath$ Dim fs

Mypath = [b7].Value 'Mypath = "E:\工具类\" ' 指定路径，修改成你自己的哦 Set fs = CreateObject("Scripting.FileSystemObject") If fs.FolderExists(Mypath) Then MsgBox "存在" Else MsgBox "不存在" End If End Sub

加一点，根据全名判断工作簿是否存在，一般用dir函数，如Len(Dir(s1)) = 0 '这句可以判断工作簿是否存在,如果路径是对的，dir函数就会取出它的名字（s1为全名含路径），例子参考

http://club.excelhome.net/viewthread.php?tid=120347 4楼

[此贴子已经被作者于2005-9-6 9:48:54编辑过]

Long_III

30、对文本的操作！先导入到excel，然后查找 ofmfAFOS.rar (15.38 KB, 下载次数: 216)

2005-9-5 13:41 上传

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

原出处为http://club.excelhome.net/viewthread.php?tid=120376

主要是一段对文本操作的代码，忘了是哪位大师写的的，我直接借用了

Sub Readdata() '把txt文件读取到excel里，txt里一行在excel也是一行 Dim fileName Dim TextLine As String Dim j%

j = 1 Cells.Clear fileName = Application.GetOpenFilename("Text Files (*.txt), *.txt") '选择一个txt文件 If fileName = False Then Exit Sub Open fileName For Input As #1 ' 打开文件。 Do While Not EOF(1) ' 循环至文件尾。 Line Input #1, TextLine ' 读入一行数据并将其赋予某变量。 Cells(j, 1) = TextLine j = j + 1 Loop Close #1 ' 关闭文件。

End Sub

chenyu

太好了，“形神兼备”，我辈求之不得。