小花鹿学习VBA记录

小花鹿

自定义排序：
Sub Macro2()
Dim i, ar
ar = Sheet1.[a1].CurrentRegion
With Application
    .AddCustomList ListArray:=ar
    i = .GetCustomListNum(ar)
    Sheet2.Range("a1:b" & Sheet2.[a65536].End(3).Row).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=i + 1, MatchCase:=False, Orientation:=xlTopToBottom, _
        SortMethod:=xlPinYin, DataOption1:=xlSortNormal
    .DeleteCustomList ListNum:=i
End With
End Sub

20141005.rar (13.41 KB, 下载次数: 46)

2014-10-6 11:12 上传

点击文件名下载附件

yishang3

收藏学习了！

yytax2010

谢谢小花鹿无私奉献。

weiyingde

学习啦，占个位置呀

小花鹿

Unicode 编码表，放在这里便于查找：
Unicode 编码表.rar (114.89 KB, 下载次数: 36)

2015-11-24 12:35 上传

点击文件名下载附件

小花鹿

下列资料来自本站，放在这里是为了查找方便，谢谢原作者。

'MuLu是要查找的文件夹,如："F:\VBA\pdf\Excel2007VBA"
'LeiXing是要查找的文件类型，如：*.xls,a?*.txt等，如果省略该参数，函数实现的是查找文件夹功能
'LeiXing参数不省略时：1、Zi为true时搜索所有子文件夹下符合要求的文件。2、Zi为false时仅搜索参数MuLu下符合要求的文件
'LeiXing参数省略时：  1、Zi为true时搜索参数MuLu下所有子文件。2、Zi为false时仅搜索参数MuLu下的文件夹
'函数的返回值是一个一维数组，可视具体情况使用
Public Function ListFile(MuLu As String, Zi As Boolean, Optional LeiXing As String = "")
    Dim MyFile As String, ms As String
    Dim arr, brr, x
    Dim i As Integer
    Set d = CreateObject("Scripting.Dictionary")
    If Right(MuLu, 1) <> "\" Then MuLu = MuLu & "\"
    d.Add MuLu, ""
    i = 0
    On Error Resume Next '这里增加错误时继续的处理代码
    Do While i < d.Count
        brr = d.keys
        MyFile = Dir(brr(i), vbDirectory)
        Do While MyFile <> ""
            If MyFile <> "." And MyFile <> ".." Then
                If (GetAttr(brr(i) & MyFile) And vbDirectory) = vbDirectory Then
                    If Err.Number Then '这里增加文件名字符错误处理判断
                        Err.Clear '#52 文件名错误
                    Else
                        d.Add (brr(i) & MyFile & "\"), ""
                    End If
                End If
            End If
            MyFile = Dir
        Loop
        If Zi = False Then Exit Do
        i = i + 1
    Loop
    If LeiXing = "" Then
        ListFile = Application.Transpose(d.keys)
    Else
        For Each x In d.keys
            MyFile = Dir(x & LeiXing)
            Do While MyFile <> ""
                ms = ms & x & MyFile & ","
                MyFile = Dir
            Loop
            If Zi = False Then Exit For
        Next
        If ms = "" Then ms = "没有符合要求的文件,"
        ListFile = Application.Transpose(Split(ms, ","))
    End If
    On Error GoTo 0
End Function

Sub selectfolder()
    Set myFolder = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹：", 0)
    If Not myFolder Is Nothing Then
        mypath$ = myFolder.Items.Item.Path
    Else
        MsgBox "你没有选择文件夹！"
        Exit Sub
    End If
    If Right(mypath, 1) <> "\" Then mypath = mypath & "\"
    '同样返回的是选中目标文件夹的绝对路径,但除了本地C盘、D盘会以"C:\"形式返回外，其余路径无"\"需要添加
Dim filearray
filearray = ListFile(mypath, True, "*.*")
Range("a1").Resize(UBound(filearray), 1) = filearray
End Sub

小花鹿

列出选中文件夹及其子文件夹中的文件：
Option Explicit
Dim FileList(1 To 65536, 1 To 1), filen&

Sub FolderFileList()
'--------------------------------------------------------------------------------------------
Dim myfolder, mypath
    Set myfolder = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹：", 0)
    If Not myfolder Is Nothing Then
        If myfolder <> "桌面" Then mypath = myfolder.Items.Item.Path
    Else
        MsgBox "你没有选择文件夹！"
        Exit Sub
    End If
    If mypath = "" Or Left(mypath, 2) = "::" Then
        MsgBox "文件夹选择错误！"
        Exit Sub
    End If
'------------------------------------------------------------------------------------------------
Dim fso, Folder, myf
Set fso = CreateObject("scripting.filesystemobject")
Set Folder = fso.getfolder(mypath)
filen = 0
For Each myf In Folder.Files
    filen = filen + 1
    FileList(filen, 1) = myf
Next myf
SubFolderFileList (mypath)
If filen > 65536 Then filen = 65536
[a1].Resize(filen) = FileList
filen = 0
End Sub

Function SubFolderFileList(pth)
Dim fso, Folder, SubFolder, myf, fd
Set fso = CreateObject("scripting.filesystemobject")
Set Folder = fso.getfolder(pth)
Set SubFolder = Folder.subfolders
On Error Resume Next
For Each fd In SubFolder
    For Each myf In fd.Files
        If myf <> "" Then
            filen = filen + 1
            FileList(filen, 1) = myf
        End If
    Next myf
    SubFolderFileList (fd.Path)
Next fd
On Error GoTo 0
End Function

列出选中文件夹及其子文件夹中的文件.rar (15.7 KB, 下载次数: 34)

2016-1-11 11:09 上传

点击文件名下载附件

小花鹿

搜索选定文件夹及其子文件夹中文件的小工具：（用窗体实时显示搜索到的文件）
Option Explicit
Dim FileList(1 To 65536, 1 To 1), filen&

Sub FolderFileList()
'--------------------------------------------------------------------------------------------
Dim myfolder, mypath
    Set myfolder = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹：", 0)
    If Not myfolder Is Nothing Then
        If myfolder <> "桌面" Then mypath = myfolder.Items.Item.Path
    Else
        MsgBox "你没有选择文件夹！"
        Exit Sub
    End If
    If mypath = "" Or Left(mypath, 2) = "::" Then
        MsgBox "文件夹选择错误！"
        Exit Sub
    End If
'------------------------------------------------------------------------------------------------
Dim fso, Folder, myf
Set fso = CreateObject("scripting.filesystemobject")
Set Folder = fso.getfolder(mypath)
filen = 0
UserForm1.Show 0
For Each myf In Folder.Files
    filen = filen + 1
    FileList(filen, 1) = myf
    UserForm1.Label1.Caption = fileedit(myf)
    DoEvents
Next myf
SubFolderFileList (mypath)
UserForm1.Caption = "文件搜索完成："
UserForm1.Label1.Caption = "文件搜索完成，共搜索到 " & filen & " 个文件！"
DoEvents
If filen > 65536 Then filen = 65536
If filen Then [a1].Resize(filen) = FileList
filen = 0
End Sub

Function SubFolderFileList(pth)
Dim fso, Folder, SubFolder, myf, fd
Set fso = CreateObject("scripting.filesystemobject")
Set Folder = fso.getfolder(pth)
Set SubFolder = Folder.subfolders
On Error Resume Next
For Each fd In SubFolder
    For Each myf In fd.Files
        If myf <> "" Then
            filen = filen + 1
            FileList(filen, 1) = myf
            UserForm1.Label1.Caption = fileedit(myf)
            DoEvents
        End If
    Next myf
    SubFolderFileList (fd.Path)
Next fd
On Error GoTo 0
End Function

Function fileedit(filenam)
Dim file1, file2, filear
If Len(filenam) > 60 Then
    filear = Split(filenam, "\")
    file2 = filear(UBound(filear))
    file1 = Replace(filenam, "\" & file2, "")
    file1 = Left(file1, 30)
    fileedit = file1 & "...\" & file2
Else
    fileedit = filenam
End If
End Function
列出选中文件夹及其子文件夹中的文件.rar (1.39 MB, 下载次数: 33)

2016-1-17 10:37 上传

点击文件名下载附件

补充内容 (2016-11-4 19:42):
Sub 遍历子文件夹()
Dim d, thispath, thisname, n&, m&, x&, mydir, dk
Set d = CreateObject("scripting.dictionary")
thispath = ThisWorkbook.Path & "\"
thisname = ThisWorkbook.Name
d(thispath) = ""
Do While n < d.Count
    dk = d.keys
    mydir = Dir(dk(n), vbDirectory)
    Do While mydir <> ""
        If mydir <> "." And mydir <> ".." Then
            If GetAttr(dk(n) & mydir) = vbDirectory Then
                d(dk(n) & mydir & "\") = ""
                m = m + 1
                Cells(m, 1) = dk(n) & mydir & "\"
            Else
                x = x + 1
                Cells(x, 7) = dk(n) & mydir
            End If
        End If
        mydir = Dir
    Loop
    n = n + 1
Loop
End Sub

小花鹿

WORD常用查找与替换实例及方法
作者：tangqingfu


Word常用查找与替换实例及方法.rar (117.09 KB, 下载次数: 50)

2016-6-4 10:38 上传

点击文件名下载附件

小花鹿

xls数据写入WORD模板，每人一个DOC文件：
Sub test()
Dim myword, thispath, mydoc, r&, i&, j&
Set myword = CreateObject("word.application")
thispath = ThisWorkbook.Path & "\"
r = Sheet1.[b65536].End(3).Row
For i = 2 To r
    mydoc = thispath & "授课通知（" & Sheet1.Cells(i, 2) & "）.doc"
    FileCopy thispath & "授课通知(模板).doc", mydoc
    With myword
        .documents.Open mydoc
        .Visible = True
        For j = 1 To 5
            If .Selection.Find.Execute("数据" & Format(j, "000")) Then
                .Selection.Text = Sheet1.Cells(i, j + 1)
                .Selection.MoveRight Unit:=1, Count:=1
            End If
        Next j
        For j = 1 To 3
            .activedocument.tables(1).cell(2, j) = Sheet1.Cells(i, j + 6)
            .activedocument.tables(1).cell(4, j) = Sheet1.Cells(i, j + 9)
        Next j
        '--------------------------------------------
        .ActiveWindow.ActivePane.View.SeekView = 9
        If .Selection.Find.Execute("数据006") Then
            .Selection.Text = "中心小学"
        End If
        .ActiveWindow.ActivePane.View.SeekView = 10
        If .Selection.Find.Execute("数据007") Then
            .Selection.Text = "宁阳县"
        End If
        '------------------------------------------
        .documents.Close True
    End With
Next i
myword.Quit
End Sub

将Excel数据对应写入已做好的Word模板的指定位置(分发).rar (38.33 KB, 下载次数: 53)

2016-6-5 12:56 上传

点击文件名下载附件

补充内容 (2016-9-28 23:16):
涉及页眉、页脚
.ActiveWindow.ActivePane.View.SeekView = 9  '页眉