小花鹿学习VBA记录

小花鹿

附件来自本站，放在这里是为了查找方便。

窗体、查询、照片：
Private Sub CommandButton1_Click() '查询
Image1.Picture = LoadPicture("")
Dim MYRANGE As Range
Dim i As Integer, MyPic$
Set MYRANGE = Sheets("sheet1").Range("A5", Range("A65536").End(xlUp)).Find(ComboBox1.Value)
If Not MYRANGE Is Nothing Then
For i = 1 To 31
Me.Controls("TEXTBOX" & i) = Cells(MYRANGE.Row, i + 1)
Next i
MyPic = ThisWorkbook.Path & "\照片\" & ComboBox1.Value & ".jpg"
If Dir(MyPic) <> "" Then
Image1.Picture = LoadPicture(MyPic)
'Image1.PictureSizeMode = 1
End If
Else
MsgBox "没有找到！" & ComboBox1.Value
End If
End Sub

小花鹿

附件来自本站，放在这里是为了查找方便，谢谢原作者。

进度条制作：
'先做的工作：加入用户窗体，右击工具箱，附加控件 找到“……ProgressBar……”，点击，确定退出，然后将其添加在窗体中，最后编写代码

Sub 进度条应用()

'--可插入过程
k = 1000 '设置循环终值（即进度条控件最大值）
UserForm1.Show 0 '以无模式调出窗体，为的是能显示进度变代
UserForm1.ProgressBar1.Max = k '设置最大值，为的是进度条和程序同时完成时填满框子
For h = 1 To k

Cells(1, 1) = h + k '加入过程

f = Format(h / k, "0.00%") '计算完成工作的百分数，2位小数，为了看到快速变化
UserForm1.Caption = "工作已经完成了" & f  '在窗体上边动态显示
UserForm1.ProgressBar1.Value = h '进度条动态显示
Next
'--可插入过程
UserForm1.Caption = "工作已经全部完成": Beep '让计算机发出声音(咚)
Unload UserForm1

End Sub

小花鹿

字典嵌套：
Sub test()
Dim arr, i%, j%, d, s, sd$
sd = "scripting.dictionary"
Set d = CreateObject(sd)
arr = [a1].CurrentRegion
For i = 2 To UBound(arr)
    For j = 2 To UBound(arr, 2)
        If arr(i, j) <> "" Then
            If d.exists(arr(i, j)) = 0 Then
                Set d(arr(i, j)) = CreateObject(sd)
            End If
            d(arr(i, j))(arr(i, 1)) = ""
        End If
    Next j
Next i
[a8].Resize(d.Count) = Application.Transpose(d.keys)
s = d.items
For i = 0 To d.Count - 1
    [b8].Offset(i).Resize(1, s(i).Count) = s(i).keys
Next i
End Sub

小花鹿

Union删除重复行：
Sub yy()
Dim Arr, i&, rng As Range, d
Set d = CreateObject("Scripting.Dictionary")
Sheet1.Activate
Arr = [a1].CurrentRegion
For i = 1 To UBound(Arr)
    If Not d.exists(Arr(i, 2)) Then
        d(Arr(i, 2)) = ""
    Else
        If rng Is Nothing Then Set rng = Rows(i) Else Set rng = Union(rng, Rows(i))
    End If
Next
If Not rng Is Nothing Then
rng.Select
MsgBox "rng.Rows.Count：" & rng.Rows.Count
    'rng.Copy Sheet2.[a1]
    'rng.Delete
End If
End Sub

小花鹿

代码来自本站，放在这里是为了查找方便，谢谢原作者。
contxt：
Function contxt(ParamArray args() As Variant) As Variant
    Dim tmptext As Variant, i As Variant, cellv As Variant
    Dim cell As Range
    tmptext = ""
    For i = 0 To UBound(args)
        If Not IsMissing(args(i)) Then
            Select Case TypeName(args(i))
            Case "Range"
                For Each cell In args(i)
                    tmptext = tmptext & cell
                Next cell
            Case "Variant()"
                For Each cellv In args(i)
                    tmptext = tmptext & cellv
                Next cellv
            Case Else
                tmptext = tmptext & args(i)
            End Select
        End If
    Next i
    contxt = tmptext
End Function

小花鹿

B列记录A列修改次数：
Option Explicit
Dim tm
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 1 Then Exit Sub
If Target.Value = tm Then Exit Sub
Target.Offset(0, 1) = Target.Offset(0, 1) + 1
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column <> 1 Then Exit Sub
tm = Target.Value
End Sub

小花鹿

列出2013年的双休日：
Sub test()
Dim daystart&, dayend&, br(1 To 65536, 1 To 2), n&, i&
daystart = Format("2013-1-1", "0")
dayend = Format("2013-12-31", "0")
For i = daystart To dayend
    If Weekday(i, 2) > 5 Then
        n = n + 1
        br(n, 1) = CDate(i)
        br(n, 2) = Format(i, "aaaa")
    End If
Next i
[a2].Resize(n, 2) = br
End Sub

小花鹿

程序暂停10秒：
Sub test()
Application.Wait (Now + TimeValue("0:00:10"))
MsgBox "ok"
End Sub

香川群子

请老师写个代码，列出thisworkbook.path下的所有xls文件（包括路径和文件名），thisworkbook.path下有xls文件，也有子文件夹，子文件夹下有xls文件，也有子子文件夹，子文件夹层数不确定，内容可保存于thisworkbook.sheet1中的A列。
要求：
1、Excel各版本通用
2、直接运行程序就可得到结果，不用进行引用之类的操作
3、程序运行效率高
查了半天，没找到理想的代码，期望你能出个经典代码。
谢谢。

……………………
2007年12月写的一个小程序……2003版的你看一下，基本可以满足你的要求。

使用后有具体改进要求请再说明。


…………
确认代码中 With Application.FileSearch 语句在2007版本中无法使用。
据说解决办法是 Dir 遍历……但这样速度效率会差很多。

香川群子

好吧，如果不要求速度，那就直接遍历循环做了：

特意为你写出来的代码。

1. Sub FileList()
   
2.     tms = Timer
   
3.     Dim flist$(65535, 3)
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     Set fld = fso.GetFolder(ThisWorkbook.Path) '以当前文件所在文件夹为指定文件夹
   
6.     Set fsb = fld.SubFolders '列出所有子文件夹
   
7.     For Each fd In fsb '遍历所有子文件夹
   
8.         For Each f In fd.Files '遍历子文件夹中的所有文件
   
9.             n = InStrRev(f.name, ".")
   
10.             If InStr(n, f.name, "xl") Then
    
11.                 flist(k, 0) = Mid(f.name, n)
    
12.                 flist(k, 1) = f.name
    
13.                 flist(k, 2) = fd.name
    
14.                 flist(k, 3) = fd.Path
    
15.                 k = k + 1
    
16.             End If
    
17.         Next
    
18.     Next
    
19.     [a1].CurrentRegion.Offset(1) = ""
    
20.     [a2].Resize(k, 4) = flist
    
21.     [b1] = "在" & fsb.Count & "个子文件夹中共找到 " & k & "个Excel文件。"
    
22.     MsgBox Format(Timer - tms, "0.000s")
    
23. End Sub
    

复制代码

哦，还不对，还需要遍历子文件夹中的子文件夹的……要用递归了。