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

浩月

能帮我注解这个吗? 工作表中有保护能自动测试是否含有保护并解开保护吗?(密码都是一样的,1956)

Sub GET_hjsong_MX() Dim files Dim i% Dim m& Dim a&, b& Dim sht As Worksheet Dim Chjs As Worksheet Dim wb As Workbook

Application.ScreenUpdating = False

SHtAdd

Set Chjs = ThisWorkbook.Sheets("hjsong") files = Application.GetOpenFilename("所有文件(*.xls),*.xls", , , , True) If Not IsArray(files) Then MsgBox "没有选定工作薄！～" Application.DisplayAlerts = False Chjs.Delete Application.DisplayAlerts = True Exit Sub End If m = 2 For i = LBound(files) To UBound(files) Set wb = Workbooks.Open(files(i)) N = Application.Substitute(wb.Name, ".xls", "") For Each sht In wb.Sheets a = GETrow(sht) b = GETcol(sht) If a > 1 And b > 1 And sht.Name = "材料清册" Then sht.Cells.AutoFilter If i = LBound(files) Then sht.Range(sht.Cells(1, 1), sht.Cells(1, b)).Copy Chjs.Cells(1, 2) For t = 1 To b Chjs.Cells(1, t + 1).ColumnWidth = sht.Cells(1, t).ColumnWidth Next t End If sht.Range(sht.Cells(2, 1), sht.Cells(a, b)).Copy Chjs.Cells(m, 2) Chjs.Cells(m, 1) = N m = GETrow(Chjs) + 1 End If Next sht ActiveWorkbook.Close False Next i Application.ScreenUpdating = True End Sub

zw1028

顶呀！大家帮龙老师顶一下呀！此帖应永远置顶！

阿斌

边看边爬。。。。终于到了140楼，历时110分钟。。。。。学习的好地方！

[此贴子已经被作者于2005-9-6 1:04:05编辑过]

Long_III

TO 皓月：

那是早先写的一个汇总的代码，我在原处更新了，并做了注释，你可以下载重新看看代码，原处为： [glow=255,vbgreen,3] 多个工作薄数据汇总到一个工作表中！ [/glow]

Sub GET_hjsong_MX() '汇总程序，打开所有的工作簿，依次取数 Dim files Dim a&, b&, m&, i% Dim sht As Worksheet, Chjs As Worksheet Dim wb As Workbook

Application.ScreenUpdating = False '关闭屏幕更新，防止闪屏、加快代码运行

files = Application.GetOpenFilename("所有文件(*.xls),*.xls", , , , True) '选取一个范围，可以选多个excel文件 If Not IsArray(files) Then '如果按取消，没有选择的时候，删除新增的表，并退出程序 MsgBox "没有选定工作薄！～" Exit Sub End If

SHtAdd '每次运行之前都重新增加一个工作表“hjsong” Set Chjs = ThisWorkbook.Sheets("hjsong") '给汇总表赋值

m = 2 For i = LBound(files) To UBound(files) '对于getopenfilename得到的是一个数组，从数组的第一个到，最后一个循环 Set wb = Workbooks.Open(files(i)) '依次打开 N = Application.Substitute(wb.Name, ".xls", "") '取工作簿的名称 For Each sht In wb.Sheets '在新打开的工作簿的工作表里循环 If sht.Name = "明细" Then '先判断表名，然后判断里面是否有数据 a = GETrow(sht) '自定义函数，计算最大行最大列，a为最大行，b为最大列 b = GETcol(sht)

If a > 1 And b > 1 Then '如果有数据的话 '如果没有对表名的控制的话，会汇总所有有数据的表，其实这里可以自定义一个函数，根据格式判断哪些工作表需要汇总

If sht.AutoFilterMode = True Then sht.AutoFilterMode = False '如果有自动筛选就取消自动筛选

If i = LBound(files) Then '第一个工作表时，复制标题（第一行内容） sht.Range(sht.Cells(1, 1), sht.Cells(1, b)).Copy Chjs.Cells(1, 2) For t = 1 To b '复制列宽 Chjs.Cells(1, t + 1).ColumnWidth = sht.Cells(1, t).ColumnWidth Next t End If

sht.Range(sht.Cells(2, 1), sht.Cells(a, b)).Copy Chjs.Cells(m, 2) '开始复制数据到B列最后的一行里 Chjs.Cells(m, 1) = N 'A列为工作簿名称 m = GETrow(Chjs) + 1 '重新计算hjsong表里的最后一非空行

End If End If Next sht wb.Close False '不保存，关闭打开的表 Next i

Application.ScreenUpdating = True '重新打开屏幕更新

End Sub

bbcdd

这种方法对初学者来说真是非常实用。

浩月

很多谢Long_III 的指导!因我的表有保护密码,所以最好能在代码中加入判断工作薄是否含密码,不含密码的忽略,含密码的按指定密码解开保护.

Function TestPassword(path) As Boolean '测试函数 Dim wb As Workbook On Error GoTo line1 Set wb = Workbooks.Open(path, Password:="") TestPassword = False wb.Close Exit Function line1: TestPassword = True End Function

Sub hjs() Dim path$, i% Dim Files Files = Application.GetOpenFilename("所有文件(*.xls),*.xls", , , , True) If IsEmpty(Files) Then Exit Sub For i = 1 To UBound(Files) MsgBox Files(i) & Chr(13) & Chr(10) & "是否有密码：" & TestPassword(Files(i)) ActiveWorkbook.UnProtect Password:="123" '解除工作簿保护 ActiveWorkbook.Protect Password:="123", Structure:=True, Windows:=False

Next End Sub

另你修改了的多个工作薄数据汇总到一个工作表中！运行后没出现结果！请改正。

Long_III

TO 皓月，就你目前的代码，有问题，因为TestPassword函数是为了确定工作簿是否含有密码，跟你的工作表是否含有密码没什么联系，“ActiveWorkbook.UnProtect Password:="123" '解除工作簿保护”，这不是解除工作簿密码，这是解除工作表密码，请分清楚。建议：你专门发贴求助，不要在这里跟贴了，你的问题与本贴的意图不一样了！

另：“另你修改了的多个工作薄数据汇总到一个工作表中！运行后没出现结果！请改正。”在我这里运行正常哦，我刚还试了一遍，请仔细看里面的注释，需要每个合并的工作簿里面有一个明细的工作表！你也可以找别人帮你测试

Long_III

31、另外一种选择文件的方法filedialog！今天看到类似的问题，就仔细看了一下帮助，里面的英文注释我大致按自己的理解转换了，代码如下：

Private Sub CommandButton1_Click() '另外一种选取打开文件的方法 Dim fd As FileDialog '定义为对话框 Dim fds

Set fd = Application.FileDialog(msoFileDialogFilePicker) ' 里面的类型 可为以下 MsoFileDialogType 常量之一，帮助里的,一般碰到不会的建议先看看帮助再发问 ' msoFileDialogFilePicker 允许用户选择一个文件 ' msoFileDialogFolderPicker 允许用户选择一个文件夹 ' msoFileDialogOpen 允许用户打开一个文件 ' msoFileDialogSaveAs 允许用户保存一个文件

With fd '多用with结果，可以加快代码运行速度，也使代码简洁，便于维护

.Filters.Clear '清除里面原先设置的类型 '.Filters.Add "Images", "*.gif; *.jpg; *.jpeg", 1 '增加所有图片选项 '.Filters.Add "Text 文件", "*.txt", 1 '这是所有txt文件 .Filters.Add "所有Excel 文件", "*.xls", 1 '增加所有所有excel文件

.ButtonName = "请选择文件" '改变按钮的名称 .Title = "选择你需要的文件哦" '你自己的标题 '.AllowMultiSelect = False '只允许选择一个文件，true可以选择多个 .AllowMultiSelect = True

If .Show = -1 Then '表明用户按下的是操作按钮-1,取消按钮为0 For Each fds In .SelectedItems '在选择里面做一个循环哦 MsgBox "选择的文件为: " & fds '弹出对话框 Next End If End With

Set fd = Nothing '释放对象 End Sub

GqOKla8D.rar (9.44 KB, 下载次数: 212)

2005-9-6 14:08 上传

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

用getopenfilename方法就介绍了，楼上面有很多例子都是用这种方法做的，本人感觉，两者在取具体文件方面，应该效果一样。只不过要取文件夹名getopenfilename就不行了，filedialog的就多点。

服务部

虽然都不太明白这些是什么意思，但还是要谢谢了！

Long_III

32、按引用来传递！注意byref声明的用法。其实我也不是很明白这些计算机内部的处理，不过按我原先书上作者的意思，说这种方法比传递值的方法要好，也比自定义函数要好，有兴趣的可以试试。看下面的例子，如果是自定义函数，只能传回一个值，用下面的方法可以传n个

Sub BreakdownName(ByVal s As String, ByRef Path As String, ByRef Name As String) 'byref表示按引用来传递 'byval表示按值来传递，一般情况省略 Dim a a = Split(s, "\") '按\分成一个数组 Name = a(UBound(a)) '取数组的最大一个，即表名 Path = Left(s, Len(s) - Len(Name)) '取路径 End Sub

'效果类似于下面的： 's = C:\Documents and Settings\hujinsong\桌面\按值来传递.xls 'Path C:\Documents and Settings\hujinsong\桌面'name 按值来传递.xls

Sub hjs() Dim m$, n$ BreakdownName ThisWorkbook.FullName, m, n '把全名分开成路径和表名，此时m就是路径，n就是表名 '在代码调用上面过程的时候，就保留了m和n的值 MsgBox "当前表路径是：" & m & Chr(10) & _ "当前表名称是：" & n End Sub

NGk4415B.rar (7.55 KB, 下载次数: 205)

2005-9-6 16:09 上传

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

[此贴子已经被作者于2005-9-7 9:23:07编辑过]