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

apple_J

感谢各位大大~~~~

小弟我是个菜鸟~~

以后多多学习~~~还需要大家多多帮助~~~

yigepure

佩服，支持，惭愧，反省。

龙兄你是我的学习的榜样呀。全部下载完毕。仔细学习。谢谢分享。

huozhe

学习中……谢谢

exceldn

受益非浅！龙三老师精神可嘉。

[em17]

Long_III

39、选择一个文件夹，给里面所有的excel表做一个链接！思路：选择一个文件夹，然后查找里面的xls文件，打开，与本工作簿建立链接，关闭！ fOX1rO1l.rar (17.4 KB, 下载次数: 307)

2005-9-13 14:45 上传

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

Private Sub CommandButton1_Click() Dim fd As FileDialog Dim Path As String, Name As String Dim T$, m%, i%, irow% Dim arr

On Error GoTo line1 '当产生错误的时候跳转到line1行，退出程序 Set fd = Application.FileDialog(msoFileDialogFolderPicker) '使用 FileDialog 对象显示“文件选取器”对话框 With fd If .Show = -1 Then '如果选择了确定按钮，则（.show的值等于0，表示按取消按钮） T = .SelectedItems(1) & "\" '用T记录下它的路径 Else Set fd = Nothing: Exit Sub '按取消之后就退出程序 End If End With

Application.ScreenUpdating = False '关闭屏幕更新，防止闪屏及加快代码执行 Application.EnableEvents = False '不运行除本程序之外的其它程序，如新工作簿被打开时运行的open程序等 Application.DisplayAlerts = False '关闭各种警告和消息，选择默认应答 Range("a3:c65536").ClearContents '清除3行及以下的内容 m = 3 '设置m的初始值，即从3行开始

With Application.FileSearch '建立一个新的搜索 .LookIn = T '范围为先前的路径 .SearchSubFolders = True '搜索范围包含当前路径下的子文件夹 .Filename = "*.xls" '搜索的程序名称为excel表 .Execute msoSortByFileName '执行搜索过程，并按文件名称排序，后面的排序参数可以省略 For i = 1 To .FoundFiles.Count s = .FoundFiles(i) BreakdownName s, Path, Name '把s分解成路径名和表名 Set wb = Workbooks.Open(s) '打开这个工作簿 For Each shtExcel In wb.Sheets '在这个工作簿里的每个工作表里循环 Range("a" & m).Hyperlinks.Add Range("a" & m), Path, , , Path & "\" 'A列增加链接，链接到路径path Range("b" & m).Hyperlinks.Add Range("b" & m), s, , , Name 'B列增加链接，链接到工作簿s Range("c" & m).Hyperlinks.Add Range("c" & m), s, "'" & shtExcel.Name & "'!a1", , shtExcel.Name 'c列增加链接，链接到每个工作表里的A1 m = m + 1 '每个工作表循环之后，m就向下一行 Next wb.Close False '不保存就关系打开的工作簿 Next i End With irow = [a65536].End(xlUp).Row '当前表里a列的最后一非空行 Set rng = Range("A3:C" & irow) '确定排序的范围 rng.Sort Key1:=Range("A4"), Order1:=xlAscending, Key2:=Range("B4") _ , Order2:=xlAscending, Key3:=Range("C4"), Order3:=xlAscending, Header:=xlGuess '排序 [a1].Copy '复制a1 rng.PasteSpecial Paste:=xlPasteFormats '粘贴格式到rng这个范围里 Application.CutCopyMode = False '取消复制之后形成的框框 line1: Application.ScreenUpdating = True '重新设置系统，为程序运行之前的设置 Application.EnableEvents = True Application.DisplayAlerts = True End Sub

plxmm

To Long_III GG ： 你的东东为何不显示出 文件啊，只是有文件夹的。这样不知道有多少的东东呢。

Long_III

程序的目的是要在一个文件夹范围里查找，故直接采用了选择文件夹的过滤器，这样除了文件夹之外的其他都不显示。如果你要显示excel文件的话，可以采用参数为msoFileDialogFilePicker的对话框或getopenfilename（之前我都写过例子）来显示打开对话框，不过这样选择的就是一个excel文件了，多了一步提取它的路径的过程！

况且，上面的代码会找到子文件夹的文件，子文件夹里的excel数目你还是看不到啊，所以就用了msoFileDialogFolderPicker

plxmm

目的是明白的。只是感觉上....[em08]

Long_III

40、选中单元格对称转置。用了两种方法，一种普通的数字转换，一种是利用数组转换，个人更喜欢数组的应用。代码如下： cRblNFiW.rar (12.65 KB, 下载次数: 226)

2005-9-13 17:33 上传

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

Private Sub CommandButton1_Click() '普通单元格转置 Dim rng As Range Dim rng1 As Range Dim Mr%, Mc%, r%, c% '%为整型变量的缩写 Dim i%, j%

On Error Resume Next '产生错误时代码继续执行下一句 Set rng = Selection '当前选定区域设置为一个变量，注意不要在工作表里有筛选，因为数组方法在筛选后的工作表里可能出现错误 If rng.Parent.AutoFilterMode = True Then rng.Parent.AutoFilterMode = False '假如工作表有筛选就取消筛选 'rng为单元格，它的parent父项就是sheet1，由于代码在sheet1里，故Me也表示它，如下面的处理

With rng r = .row '选定区域的最小行 c = .Column '选定区域的最小列 Mr = .Rows.Count '选定区域行的总数 Mc = .Columns.Count '选定区域列的总数

For i = r To r + Mr - 1 '在行里循环 For j = c To c + Mc - 1 '在列里循环 Cells(i, (c + Mc - 1) * 2 - j + 1).Value = Cells(i, j).Value Next '(c + Mc - 1) * 2 - j + 1这里需要自己动脑筋想了，可以自己画一个对称图来理解 Next End With '循环过程中行是不变的，列对称在变

End Sub

Private Sub CommandButton2_Click() '数组方法 Dim arr, arr1() Dim Mr%, Mc%, r%, c% Dim rng As Range

On Error Resume Next '产生错误时代码继续执行下一句 Set rng = Selection '当前选定区域设置为一个变量 If rng.Count = 1 Then rng.Offset(0, 1).Value = rng.Value: Exit Sub '由于数组不支持一个单元格的情况，故单独增加一个判断处理 If Me.AutoFilterMode = True Then Me.AutoFilterMode = False '假如工作表有筛选就取消筛选

With rng r = .row '选定区域的最小行 c = .Column '选定区域的最小列 Mr = .Rows.Count '选定区域行的总数 Mc = .Columns.Count '选定区域列的总数 End With

arr = rng '把单元格赋值给数组arr，这时数组的值为arr(1 to Mr,1 to Mc) ReDim arr1(1 To Mr, 1 To Mc)

For j = 1 To Mc '列的循环正好与原数组相反 For i = 1 To Mr '行的循环不变 arr1(i, Mc - j + 1) = arr(i, j) '如果j从1到6，则mc为6，即6－j+1＝7-j，“Mc - j + 1”就是从6到1了 Next Next Cells(r, c + Mc).Resize(Mr, Mc) = arr1 '给单元格赋值 End Sub

天街小雨

真是太好了，太谢谢了