越学习，越发现自己的无知。

lrlxxqxa

http://club.excelhome.net/viewth ... p;extra=&page=1
老朽和大灰狼提供的方法。
注意45楼的更新，修正两处：
1、对打开文件夹目录的操作实现记忆功能；
2、对不同文件夹下的同名文件，容错
===================================================

1. Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
   
2. Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
   
3. 
   
4. Private Sub CommandButton1_Click()
   
5.     Set objShell = CreateObject("Shell.Application")
   
6.     Set objFolder = objShell.BrowseForFolder(0, "选择文件夹", 0, 0)
   
7.     If Not objFolder Is Nothing Then
   
8.         If Right(objFolder.self.Path, 1) = "" Then
   
9.             TextBox1 = objFolder.self.Path
   
10.         Else
    
11.             TextBox1 = objFolder.self.Path & ""
    
12.         End If
    
13.     End If
    
14.     Set objFolder = Nothing
    
15.     Set objShell = Nothing
    
16. End Sub
    
17. 
    
18. Private Sub CommandButton2_Click()
    
19.     Unload Me
    
20. End Sub
    
21. 
    
22. Private Sub CommandButton3_Click()
    
23.     Call 建立资料目录
    
24. End Sub
    
25. 
    
26. Private Sub UserForm_Initialize()
    
27.     Dim i As Integer
    
28.     Dim temp As String * 255
    
29. 
    
30.     i = GetPrivateProfileString("LastFindInfo", "Folder", "c:", temp, 255, "ExcelFind.ini")
    
31.     TextBox1 = temp
    
32. End Sub
    
33. Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)   '保存上次打开文件夹路径
    
34.     Dim i As Integer
    
35.     Dim temp As String * 255
    
36.     temp = TextBox1
    
37.     i = WritePrivateProfileString("LastFindInfo", "Folder", temp, "ExcelFind.ini")
    
38. End Sub
    
39. Sub 建立资料目录()    '使用双字典，旨在提高速度
    
40.     Dim yy()
    
41.     Dim xx    '(1 To 1000, 1 To 4)
    
42.     Dim MyName, Dic, Did, i, T, F, TT, MyFileName, objShell, objFolder, lj, Ke, sz, Sh, rng As Range, cell As Range
    
43.     Dim ObjFso As New FileSystemObject
    
44.     'On Error Resume Next
    
45.     'Set objShell = CreateObject("Shell.Application")
    
46.     'Set objFolder = objShell.BrowseForFolder(0, "选择文件夹", 0, 0)
    
47.     'If Not objFolder Is Nothing Then lj = objFolder.self.Path & ""
    
48.     'Set objFolder = Nothing
    
49.     'Set objShell = Nothing
    
50.     lj = TextBox1
    
51.     Application.ScreenUpdating = False
    
52.     T = Timer
    
53.     Set Dic = CreateObject("Scripting.Dictionary")    '创建一个字典对象
    
54.     Set Did = CreateObject("Scripting.Dictionary")
    
55.     Dic.Add (lj), ""
    
56.     i = 0
    
57.     Do While i < Dic.Count
    
58.         Ke = Dic.keys   '开始遍历字典
    
59.         MyName = Dir(Ke(i), vbDirectory)    '查找目录
    
60.         Do While MyName <> ""
    
61.             If MyName <> "." And MyName <> ".." Then
    
62.                 If (GetAttr(Ke(i) & MyName) And vbDirectory) = vbDirectory Then    '如果是次级目录
    
63.                     Dic.Add (Ke(i) & MyName & ""), ""  '就往字典中添加这个次级目录名作为一个条目
    
64.                 End If
    
65.             End If
    
66.             MyName = Dir    '继续遍历寻找
    
67.         Loop
    
68.         i = i + 1
    
69.     Loop
    
70.     sz = Split(lj, "")
    
71.     If UBound(sz) = 1 Then
    
72.         ls = Left(lj, 1) & "盘"
    
73.     Else
    
74.         ls = sz(UBound(sz) - 1)
    
75.     End If
    
76.     nTotalLine = 0
    
77.     p = 1
    
78.     i_p = 1
    
79.     Did.Add (ls & "文件清单"), ""    '以查找D盘下所有EXCEL文件为例
    
80.     For Each Ke In Dic.keys
    
81.         'xx(p, 1) = Ke
    
82.         'xx(p, 4) = Ke
    
83.         ReDim Preserve yy(p)
    
84.         yy(p) = Ke & "|" & " " & "|" & " " & "|" & Ke
    
85.         p = p + 1
    
86.         Did.Add Ke, ""
    
87.         MyFileName = Dir(Ke & "*.*")
    
88.         Do While MyFileName <> ""
    
89.             If Did.Exists(MyFileName) Then
    
90.                 Did.Add (Ke & MyFileName), ""
    
91.             Else
    
92.                 Did.Add (MyFileName), ""
    
93.             End If
    
94.             '    xx(p, 1) = MyFileName
    
95.             '    xx(p, 2) = Round(FileLen(Ke & MyFileName) / 1024, 2) & "K"
    
96.             Set ObjFile = ObjFso.GetFile(Ke & MyFileName)
    
97.             '    xx(p, 3) = ObjFile.DateLastModified '最后修改日期
    
98.             '    xx(p, 4) = Ke & MyFileName
    
99.             ReDim Preserve yy(p)
    
100.             yy(p) = MyFileName & "|" & Round(FileLen(Ke & MyFileName) / 1024, 2) & "K" & "|" & ObjFile.DateLastModified & "|" & Ke & MyFileName
     
101.             p = p + 1
     
102.             MyFileName = Dir
     
103.         Loop
     
104.         '   Did.Add "", ""
     
105.         '   p = p + 1
     
106.     Next
     
107.     For Each Sh In ThisWorkbook.Worksheets
     
108.         If Sh.Name = ls & "文件清单" Then
     
109.             Sheets(ls & "文件清单").Cells.Delete
     
110.             F = True
     
111.             Exit For
     
112.         Else
     
113.             F = False
     
114.         End If
     
115.     Next
     
116.     If Not F Then
     
117.         Sheets.Add.Name = ls & "文件清单"
     
118.     End If
     
119.     'Sheets(ls & "文件清单").[A1].Resize(Did.Count, 1) = WorksheetFunction.Transpose(Did.keys)
     
120. 
     
121. 
     
122.     With Sheets(ls & "文件清单")
     
123.         .Activate
     
124.         .Cells(1, 1) = "路径文件名"
     
125.         .Cells(1, 2) = "文件大小"
     
126.         .Cells(1, 3) = "时间属性"
     
127.         ReDim xx(1 To p - 1, 1 To 4)
     
128.         For i = 1 To p - 1
     
129.             a = Split(yy(i), "|")
     
130.             For j = 0 To 3
     
131.                 xx(i_p, j + 1) = a(j)
     
132.             Next
     
133.             i_p = i_p + 1
     
134.         Next
     
135.         .Range("a2:c" & i_p) = xx
     
136.         j = Did.Count
     
137.         Set rng = .Range("a1:c" & j)
     
138.         For s = 1 To j - 1
     
139.             .Cells(s + 1, 1).Select
     
140.             .Cells(s + 1, 1).Hyperlinks.Add Anchor:=Selection, Address:=xx(s, 4)    '.Cells(S, 1)
     
141.             rng.EntireColumn.AutoFit
     
142.         Next s
     
143.     End With
     
144.     Set rng = Nothing
     
145.     ThisWorkbook.SaveAs ThisWorkbook.Path & "" & ls & "文件清单"
     
146.     Application.ScreenUpdating = True
     
147.     TT = Timer - T
     
148.     MsgBox TT    'Minute(TT) & "分" & Second(TT) & "秒"
     
149. End Sub
     

复制代码

[ 本帖最后由 lrlxxqxa 于 2011-7-9 12:07 编辑 ]

tywx

谢谢分享 我要好好学习

lrlxxqxa

http://club.excelhome.net/viewthread.php?tid=285933
虽然API目前看不懂，先过一遍

Option Explicit
'//****************************************************************************************************************************************
'//此模块演示了一个没有边框和标题栏的窗体
'//****************************************************************************************************************************************
'//以下声明API函数
'//查找窗口
Private Declare Function FindWindow _
    Lib "user32" _
    Alias "FindWindowA" ( _
        ByVal lpClassName As String, _
        ByVal lpWindowName As String) _
As Long
'//取得窗口样式位
Private Declare Function GetWindowLong _
    Lib "user32" _
    Alias "GetWindowLongA" ( _
        ByVal Hwnd As Long, _
        ByVal nIndex As Long) _
As Long
'//设置窗口样式位
Private Declare Function SetWindowLong _
    Lib "user32" _
    Alias "SetWindowLongA" ( _
        ByVal Hwnd As Long, _
        ByVal nIndex As Long, _
        ByVal dwNewLong As Long) _
As Long
'//重绘窗体标题栏
Private Declare Function DrawMenuBar _
    Lib "user32" ( _
        ByVal Hwnd As Long) _
As Long
'//以下定义常数及变量
Private Const GWL_STYLE = (-16)                         '窗口样式
Private Const WS_CAPTION = &HC00000                  '窗口标题栏
Private Const GWL_EXSTYLE = (-20)                      '窗体拓展样式
Private Const WS_EX_DLGMODALFRAME = &H1&        '窗体边框
Private Hwnd As Long                                    '用于寄存窗体句柄
'//****************************************************************************************************************************************
'//                                               程序
Private Sub UserForm_Initialize()
    Dim Istype As Long
    '//查找本窗口句柄
    Hwnd = FindWindow("ThunderDFrame", Me.Caption)
    '//取得窗口样式位
    Istype = GetWindowLong(Hwnd, GWL_STYLE)
    '//窗体样式位: 原样式无标题
    Istype = Istype And Not WS_CAPTION
    '//重设窗体样式位
    SetWindowLong Hwnd, GWL_STYLE, Istype
    '//取得拓展窗口样式位
    Istype = GetWindowLong(Hwnd, GWL_EXSTYLE)
    '//拓展窗体样式位: 原样式无边框
    Istype = Istype And Not WS_EX_DLGMODALFRAME
    '//重设拓展窗体样式位
    SetWindowLong Hwnd, GWL_EXSTYLE, Istype
    '//重绘窗体标题栏
    DrawMenuBar Hwnd
End Sub
'/--------------------------------------------------------------------------------------------------------------------------------------------------------------------

lrlxxqxa

精确设置列宽、行高 单元格适应图片，正方形单元格
http://club.excelhome.net/viewth ... =%D5%FD%B7%BD%D0%CE
[基础应用] 如何设置行高和列宽值得到行高和列宽均为5像素的100个正方格？ http://www.exceltip.net/thread-24740-1-1-25594.html

lrlxxqxa

http://club.excelhome.net/forum. ... 327&pid=3689798
选定要保护的工作表,ctrl+A全选所有单元格,ctrl+1打开单元格格式对话框-保护-去掉"锁定"前面的对钩.Alt+11打开VBE窗口,在左上的工程窗口选择要保护的工作表,在右面的代码窗口写代码:

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. Application.EnableEvents = 0
   
3. ActiveSheet.Unprotect Password:="123"
   
4. If Target <> "" Then Target.Locked = 1
   
5. ActiveSheet.Protect Password:="123"
   
6. Application.EnableEvents = 1
   
7. End Sub

复制代码

保存.
这个设置的密码是123

bluexuemei

sum支持工作表三维引用，但不支持引用函数产生的三维引用，必要时需要使用n（）函数取得每个维度的左上角值再汇总；
SUBTOTAL()支持引用函数产生的三维引用，但对工作表三维引用却不支持，这点和sum互补.
今天才知道这个区别。

莫悠悠

不知道什么时候会用到，先留个脚印

shizz168

谢谢    学习了 ......

andrewxiao312

好好学习,天天向上

andrewxiao312

谢谢楼主的归纳总结!