FSO之文件及文件夹操作及获取相关属性等

FSO之文件及文件夹操作及获取相关属性等

本文摘自excelhome论坛liulang0808的文章，主要是太经典了，怕将来不开源了，记录下来，以备常常学习和借用。

总体的代码框架如下：

1
2
3
4
5
6
Sub 按钮1_Click()
   Application.ScreenUpdating = False
    Set fso =CreateObject("Scripting.FileSystemObject")
'    此处根据具体操作添加代码
   Application.ScreenUpdating = True
End Sub

一、文件有关的操作

  1. 判断文件是否存在

FileExists方法用于判断指定的文件是否存在，若存在则返回True。其语法为：
fso.FileExists(Filepath)
Filepath为文件完整路径，String类型，不能包含有通配符。如果用户有充分的权限，Filepath可以是网络路径或共享名
示例如下：

1
2
3
4
5
6
7
8
9
10
11
Sub 按钮1_Click()
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    strfile = Application.InputBox("请输入文件的完整名称:", "请输入文件的完整名称:", , , , , , 2)
    If fso.fileexists(strfile) Then
        MsgBox strfile & " :存在"
    Else
        MsgBox strfile & " :不存在"
    End If
    Application.ScreenUpdating = True
End Sub
  1. 移动文件

MoveFile方法用来移动文件，将文件从一个文件夹移动到另一个文件夹。其语法为：
FSO.MoveFile source,destination
参数source必需，指定要移动的文件的路径，String类型。参数destination必需，指定文件移动操作中的目标位置的路径，String类型。
如果Source包含通配符或者destination以路径分隔符结尾，则认为destination是一个路径，否则认为destination的最后一部分是文件名。
如果目标文件已经存在，则将出现一个错误。
source可以包含通配符，但只能出现在它的最后一部分中。
destination参数不能包含通配符。
source或destination可以是相对路径或绝对路径，可以是网络路径或共享名。
MoveFile方法在开始操作前先解析source和destination这两个参数。
实例如下：

1
2
3
4
5
6
7
8
9
10
Sub 按钮1_Click()
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    sourcefile = ThisWorkbook.Path & "\txt\*" '将txt文件下所有文件移走，首先需要确认是相关文件时针的存在

    destinationfolder = ThisWorkbook.Path & "\tt\" '注意路径格式“tt\”，后面的“\”

    fso.movefile sourcefile, destinationfolder
    Application.ScreenUpdating = True
End Sub
  1. 拷贝文件

CopyFile方法用来复制文件，将文件从一个文件夹复制到另一个文件夹。其语法为：
fso.CopyFile Source,Destination [,OverwriteFiles]
参数Source必需，指定要复制的文件的路径和名称，String类型。参数Destination必需，代表复制文件的目标路径和文件名（可选），String类型。参数OverwriteFiles可选，表示是否覆盖一个现有文件的标志，True表示覆盖，False表示不覆盖，Boolean类型，默认值为True。
参数source中源路径可以是绝对路径或相对路径，源文件名可包含通配符但源路径不能。在参数Destination中不能包含通配符。
如果目标路径或文件设置为只读，则无论OverwriteFiles参数的值如何，都将无法完成CopyFile方法。如果参数OverwriteFiles设置为False且Destination指定的文件已经存在，则会产生一个运行时错误“文件已经存在”。如果在复制多个文件时出现错误，CopyFile方法将立即停止复制操作，该方法不具有撤销错误前文件复制操作的返回功能。如果用户有充分的权限，那么source或destination可以是网络路径或共享名。 CopyFile方法可以复制一个保存在特定文件夹中的文件。如果文件夹本身有包含文件的子文件夹，则使用CopyFile方法不能复制这些文件，应该使用CopyFolder方法。
具体实例如下：

1
2
3
4
5
6
7
8
Sub 按钮1_Click()
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    sourcefile = ThisWorkbook.Path & "\txt\*" '将txt文件下所有文件拷贝走，首先需要确认是相关文件时针的存在
    destinationfolder = ThisWorkbook.Path & "\tt\" '注意此处不同于movefile，后面的“\”可以省略，只要确实存在该文件夹
    fso.copyfile sourcefile, destinationfolder
    Application.ScreenUpdating = True
End Sub
  1. 删除文件

DeleteFile方法删除指定的一个或多个文件。其语法为：
fso.DeleteFile FileSpec[,Force]
参数FileSpec必需，代表要删除的单个文件或多个文件的名称和路径，String类型，可以在路径的最后部分包含通配符，可以为相对路径或绝对路径。如果在FileSpec中只有文件名，则认为该文件在应用程序的当前驱动器和文件夹中。参数Force可选，如果将其设置为True，则忽略文件的只读标志并删除该文件，Boolean类型，默认值为False。
如果指定要删除的文件已经打开，该方法将失败并出现一个“Permission Denied”错误。如果找不到指定的文件，则该方法失败。
如果在删除多个文件的过程中出现错误，DeleteFile方法将立即停止删除操作，即不能删除余下的文件部分。该方法不具有撤销产生错误前文件删除操作的返回功能。
如果用户有充分的权限，源路径或目标路径可以是网络路径或共享名。
注意：DeleteFile方法永久性地删除文件，并不把这些文件移到回收站中。
示例如下：

1
2
3
4
5
6
7
Sub 按钮1_Click()
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    strfile = Application.InputBox("请输入文件的完整名称:", "请输入文件的完整名称:", , , , , , 2)
    fso.deletefile strfile
    Application.ScreenUpdating = True
End Sub
  1. GetFile方法

GetFile方法用来返回一个File对象。
其语法为：fso.GetFile (FilePath)
参数FilePath必需，指定路径和文件名，String类型。可以是绝对路径或相对路径。如果FilePath是一个共享名或网络路径，GetFile确认该驱动器或共享是File对象创建进程的一部分。如果参数FilePath指定的路径的任何部分不能连接或不存在，就会产生错误。
GetFile方法返回的是File对象，而不是TextStream对象。File对象不是打开的文件，主要是用来完成如复制或移动文件和询问文件的属性之类的方法。尽管不能对File对象进行写或读操作，但可以使用File对象的OpenAsTextStream方法获得TextStream对象。
要获得所需的FilePath字符串，首先应该使用GetAbsolutePathName方法。如果FilePath包含网络驱动器或共享，可以在调用GetFile方法之前用DriveExists方法来检验所需的驱动器是否可用。
因为在FilePath指定的文件不存在时会产生错误，所以应该在调用GetFile之前调用FileExists方法确定文件是否存在。
必须用Set语句将File对象赋给一个局部对象变量。
具体实例见下面的属性代码

  1. 文件的各种属性
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Sub 按钮1_Click()
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    strfile = Application.InputBox("请输入文件的完整名称:", "请输入文件的完整名称:", , , , , , 2)
    Set objfile = fso.GetFile(strfile)
    If fso.fileexists(strfile) Then
      
        sReturn = "文件属性： " & objfile.Attributes & vbCrLf
         
        sReturn = sReturn & "文件创建日期： " & objfile.DateCreated & vbCrLf
         
        sReturn = sReturn & "文件修改日期： " & objfile.DateLastModified & vbCrLf
         
        sReturn = sReturn & "文件大小 " & FormatNumber(objfile.Size / 1024, -1)
         
        sReturn = sReturn & "Kb" & vbCrLf
         
        sReturn = sReturn & "文件类型： " & objfile.Type & vbCrLf

        MsgBox sReturn

    Else
        MsgBox strfile & " :不存在"
    End If
    Application.ScreenUpdating = True
End Sub

二、文件夹操作

  1. 判断文件夹是否存在

FolderExists方法可以判断指定的文件夹是否存在，若存在则返回True。其语法为：
fso.FolderExists(FolderSpec)
参数FolderSpec指定文件夹的完整路径，String类型，不能包含通配符。
如果用户有充分的权限，FolderSpec可以是网络路径或共享名，例如：
If fso.FileExists (“\NTSERV1\d$\TestPath") Then

示例如下：

1
2
3
4
5
6
7
8
9
10
11
Sub 按钮1_Click()
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    strfile = Application.InputBox("请输入文件的完整名称:", "请输入文件的完整名称:", , , , , , 2)
    If fso.fileexists(strfile) Then
        MsgBox strfile & " :存在"
    Else
        MsgBox strfile & " :不存在"
    End If
    Application.ScreenUpdating = True
End Sub
  1. 移动

MoveFolder方法用来移动文件夹，将文件夹及其文件和子文件夹一起从某个位置移动到另一个位置。其语法为：
fso.MoveFolder source,destination
参数Source指定要移动的文件夹的路径，String类型。参数destination指定文件夹移动操作中目标位置的路径，String类型。
Source必须以通配符或非路径分隔符结束，可以使用通配符，但必须出现在最后一部分中。destination不能使用通配符。除非不允许使用通配符，否则源文件夹中所有的子文件夹和文件都被复制到destination指定的位置，也就是说MoveFolder方法是递归的。
如果destination用路径分隔符结束或者source用通配符结束，MoveFolder就认为source中指定的文件夹存在于destination中。例如，假设有如下文件夹结构：
MoveFolder “C:\Rootone*“,”C:\RootTow"
产生如下文件夹结构：
MoveFolder “C:\Rootone”,”C:\RootTwo"
产生如下文件夹结构：
Source和destination可以为绝对路径或相对路径，可以为网络路径或共享名。
MoveFile方法在开始操作前先解析source和destination这两个参数。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub 按钮1_Click()
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    sfolder = ThisWorkbook.Path & "\tt"
    dfolder = ThisWorkbook.Path & "\txt\"
    If Not fso.folderexists(sfolder) Then
        MsgBox sfolder & " :不存在"
        Exit Sub
    End If
   
    If Not fso.folderexists(dfolder) Then
        MsgBox dfolder & " :不存在"
        Exit Sub
    End If
    fso.movefolder sfolder, dfolder
    Application.ScreenUpdating = True
End Sub
  1. 拷贝

CopyFolder方法用于复制文件夹，即将一个文件夹的内容（包括其子文件夹）复制到其他位置。其语法为：
fso.CopyFolder Source,Destination[,OverwriteFiles]
参数Source必需，指定要复制的文件夹的路径和文件夹名，String类型，必须使用通配符或者非路径分隔符来结束。参数Destination必需，指定文件夹复制操作的目标文件夹的路径，String类型。参数OverwriteFiles可选，表示是否被覆盖一个现有文件的标志，True表示覆盖，False表示不覆盖，Boolean类型。
通配符只能在参数Source中使用，但是只能放在最后的组件中。在参数Destination中不能使用通配符。
除非不允许使用通配符，否则就可以把源文件夹中的所有子文件夹和文件都复制到Destination指定的文件夹中，也就是说CopyFolder方法是递归的。
如果参数Destination以一个路径分隔符结束或者参数Source以一个通配符结束，CopyFolder方法就认为参数Source中的指定的文件夹存在于参数Destination中，否则就创建这样一个文件夹。例如，假设有如下的文件夹结构：
CopyFolder “C:\Rootone*“,”C:\RootTwo”
产生如下的文件夹结构：
CopyFolder “C:\Rootone”,”C:\RootTwo"
产生如下的文件夹结构：
如果参数Destination指定的目标路径或任意文件被设置成只读属性，则不论OverwriteFiles的值如何，CopyFolder方法者将失效。
如果OverwriterFiles设置为False，而参数Source指定的源文件夹或任何文件存在于参数Destination中，将产生运行时错误“文件已经存在”。
如果在复制多个文件夹时出现错误，CopyFolder方法立即停止复制操作，不再复制余下要复制的文件。该方法不具有撤销产生错误前文件复制操作的返回功能。
如果用户有充分的权限，source或destination都可以是网络路径或共享名，例如：
CopyFolder “C:\Rootone”,”\NTSERV1\d$\RootTwo"

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub 按钮1_Click()
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    sfolder = ThisWorkbook.Path & "\tt"
    dfolder = ThisWorkbook.Path & "\txt\"
    If Not fso.folderexists(sfolder) Then
        MsgBox sfolder & " :不存在"
        Exit Sub
    End If
   
    If Not fso.folderexists(dfolder) Then
        MsgBox dfolder & " :不存在"
        Exit Sub
    End If
    fso.copyfolder sfolder, dfolder
    Application.ScreenUpdating = True
End Sub
  1. 删除文件夹

DeleteFolder方法用于删除指定的文件夹及其所有的文件和子文件夹。其语法为：
fso.DeleteFolder FileSpec[,Force]
参数FileSpec必需，指定要删除的文件夹的名称和路径，String类型。在参数FileSpec中，可以在路径的最后部分包含通配符，但不能用路径分隔符结束，可以为相对路径或绝对路径。
参数Force可选，Boolean类型，如果设置为True，将忽略文件的只读标志并删除这个文件。默认为False。如果参数Force设置为False并且文件夹中的任意一个文件为只读，则该方法将失败。如果找不到指定的文件夹，则该方法失败。
如果指定的文件夹中有文件已经打开，则不能完成删除操作，且产生一个“Permisson Denied”错误。DeleteFolder方法删除指定文件夹中的所有内容，包括其他文件夹及其内容。
如果在删除多个文件或文件夹时出现错误，DeleteFolder方法将立即停止删除操作，即不能删除余下的文件夹或文件。该方法不具有撤销产生错误前文件夹删除操作的返回功能。
DeleteFolder方法永久性删除文件夹，并不把它们移到回收站中。
如果用户有充分的权限，源路径和目标路径可以是网络路径或共享名，例如：
DeleteFolder “\RootTest”

示例如下：

1
2
3
4
5
6
7
8
9
10
11
12
Sub 按钮1_Click()
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    sfolder = ThisWorkbook.Path & "\txt\tt"
    If Not fso.folderexists(sfolder) Then
        MsgBox sfolder & " :不存在"
        Exit Sub
    End If
   
    fso.deletefolder sfolder
    Application.ScreenUpdating = True
End Sub
  1. 创建文件夹

CreateFolder方法用于在指定的路径下创建一个新文件夹，并返回其Folder对象。其语法为：
fso.CreateFolder (Path)
参数Path必需，为一个返回要创建的新文件夹名的表达式，String类型。Path指定的路径可以是相对路径也可以是绝对路径，如果没有指定路径则使用当前驱动器和目录作为路径。在新的文件夹名中不能使用通配符。
如果参数Path指定的路径为只读，则CreateFolder方法将失败；如果参数Path指定的文件夹已经存在，就会产生运行时错误“文件已经存在”。如果用户有充分的权限，则参数Path可以指定为网络路径或共享名，例如：
Fso.CreateFolder “\NTSERV1\RootTest\newFolder”
示例如下：

1
2
3
4
5
6
7
8
9
10
11
12
Sub 按钮1_Click()
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    sfolder = ThisWorkbook.Path & "\thisfolder"
    If fso.folderexists(sfolder) Then
        MsgBox sfolder & " :已经存在"
        Exit Sub
    End If
   
    fso.CreateFolder sfolder
    Application.ScreenUpdating = True
End Sub
  1. GetAbsolutePathName方法

将相对路径转变为一个全限定路径（包括驱动器名），返回一个字符串，包含一个给定的路径说明的绝对路径。其语法为：
fso.GetAbsolutePathName (Path)
参数Path必需，代表路径说明，String类型。
“.”返回当前文件夹的驱动器名和完整路径。“..”返回当前文件夹的父文件夹的驱动器名和路径。“filename”返回当前文件夹中的文件的驱动器名、路径及文件名。
所有相对路径名均以当前文件夹为基准。
如果没有明确地提供驱动器作为Path的一部分，就以当前驱动器作为Path参数中的驱动器。在Path中可以包含任意个通配符。
对于映射网络驱动器和共享而言，这种方法不能返回完整的网络地址，而是返回全限定的本地路径和本地驱动器名。
GetAbsolutePathName不能检验指定路径中是否存在某个给定的文件或文件夹

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub 按钮1_Click()
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    sfolder = "thisfolder"
    If fso.folderexists(sfolder) Then
        MsgBox sfolder & " :已经存在"
        Exit Sub
    End If
   
    str1 = fso.GetAbsolutePathName(sfolder)
    MsgBox sfolder & "  ：的绝对路径为： " & str1
    Application.ScreenUpdating = True
End Sub
  1. GetParentFolderName方法

返回给定路径中最后部分前的文件夹名，其语法为：
fso.GetParentFolderName (Path)
参数Path必需，指定路径说明，String类型。
如果从Path中不能确定父文件夹名，就返回一个零长字符串（””）。Path可以为相对路径或绝对路径。可以是网络驱动器或共享。
GetParentFolderName方法不能检验Path的某个部分是否存在。
GetParentFolderName方法认为Path中不属于驱动器说明的那部分字符串除了最后一部分外余下的字符串就是父文件夹。除此之外它不做任何其他检测，更像是一个字符串解析和处理例程而不是与对象处理有关的例程。

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub 按钮1_Click()
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    sfolder = ThisWorkbook.Path & "\tt\"
    If Not fso.folderexists(sfolder) Then
        MsgBox sfolder & " :不存在"
        Exit Sub
    End If
   
    str1 = fso.GetParentFolderName(sfolder)
    MsgBox sfolder & "  ：父路径： " & str1
    Application.ScreenUpdating = True
End Sub
  1. GetSpecialFolder方法

GetSpecialFolder方法返回操作系统文件夹路径，其中0代表Windows文件夹，1代表System（系统）文件夹，2代表Temp（临时）文件夹。其语法为：
fso.GetSpecialFolder (SpecialFolder)
参数SpecialFolder必需，为特殊的文件夹常数，表示三种特殊系统文件夹中其中一个的值。
可以使用Set语句将Folder对象赋给一个局部对象变量，但是如果只对检索特殊的文件夹感兴趣，就可以使用下列语句来实现：
sPath=fso.GetSpecialFolder (iFolderConst)
或：
sPath=fso.GetSpecialFolder (iFolderConst).Path
由于Path属性是Folder对象的缺省属性，所认第一个语句有效。因为不是给一个对象变量赋值，所以赋给sPath的值是缺省的Path属性值，而不是对象引用。
示例

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub 按钮1_Click()
    Application.ScreenUpdating = False
    Dim strWindowsFolder As String
    Dim strSystemFolder As String
    Dim strTempFolder As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    strWindowsFolder = fso.GetSpecialFolder(0)
    strSystemFolder = fso.GetSpecialFolder(1)
    strTempFolder = fso.GetSpecialFolder(2)
    MsgBox strWindowsFolder & vbCrLf & strSystemFolder & vbCrLf _
    & strTempFolder, vbInformation + vbOKOnly, "Special Folders"
    Application.ScreenUpdating = True
End Sub
  1. GetFolder方法

GetFolder方法返回Folder对象。其语法为：
fso.GetFolder (FolderPath)
参数FolderPath必需，指定所需文件夹的路径，String类型，可以为相对路径或绝对路径。如果FolderPath是共享名或网络路径，GetFolder确认该驱动器或共享是File对象创建进程的一部分。如果FolderPath的任何部分不能连接或不存在，就会产生一个错误。
要获得所需的Path字符串，首先应该使用GetAbsolutePathName方法。如果FolderPath包含一个网络驱动器或共享，可以在调用GetFolder方法之前使用DriveExists方法确认指定的驱动器是否可用。由于GetFolder方法要求FolderPath是一个有效文件夹的路径，所以应调用FolderExists方法来检验FolderPath是否存在。
必须使用Set语句将Folder对象赋给一个局部对象变量。
具体实例见楼下 属性获取

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub 按钮1_Click()
    Application.ScreenUpdating = False

    Dim sReturn As String
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder1 = fso.GetFolder(ThisWorkbook.Path & "\")
    sReturn = "文件夹属性： " & folder1.Attributes & vbCrLf
    '获取最近一次访问的时间
    sReturn = sReturn & "创建时间： " & folder1.Datecreated & vbCrLf
    sReturn = sReturn & "最后访问时间： is " & folder1.DateLastAccessed & vbCrLf
    '获取最后一次修改的时间
    sReturn = sReturn & "最后修改时间： " & folder1.DateLastModified & vbCrLf
    '获取文件夹的大小
    sReturn = sReturn & "文件夹大小： " & FormatNumber(folder1.Size / 1024, 0)
    sReturn = sReturn & "Kb" & vbCrLf
    '判断文件或文件夹类型
    sReturn = sReturn & "类型为： " & folder1.Type & vbCrLf
    MsgBox sReturn
    Application.ScreenUpdating = True
End Sub

三、另一牛人的代码- 跟我学 【喜迎2015立春】遍历文件夹(含子文件夹)方法 ABC

以下内容摘自另一牛人香川群子的文章，其中FSO操作代码简洁，带有弹出框选择目标位置，也摘录下来：

首先要介绍，在VBA代码运行以后，调用【目标文件夹】的方法：

① 微软Excel VBA 默认选择文件夹的Dialog对话框

1
2
3
4
5
6
7
Sub ListFilesTest()
    With Application.FileDialog(msoFileDialogFolderPicker) '运行后出现标准的选择文件夹对话框        
        If .Show Then myPath = .SelectedItems(1) Else Exit Sub '如选中则返回=-1 / 取消未选则返回=0 
    End With
    If Right(myPath, 1) <> "" Then myPath = myPath & "" 
    '返回的是选中目标文件夹的绝对路径,但除了本地C盘、D盘会以"C:"形式返回外，其余路径无""需要自己添加 
End Sub

② 视窗浏览器界面选择目标文件夹

1
2
3
4
5
6
7
Sub ListFilesTest()
    Set myFolder = CreateObject("Shell.Application").BrowseForFolder(0, "GetFolder", 0)
    If Not myFolder Is Nothing Then myPath$ = myFolder.Items.Item.Path Else MsgBox "Folder not Selected": Exit Sub
    If Right(myPath, 1) <> "" Then myPath = myPath & ""
    '同样返回的是选中目标文件夹的绝对路径,但除了本地C盘、D盘会以"C:"形式返回外，其余路径无""需要添加 

End Sub

这两种选择目标文件夹的方法，总的效果应该都不错。
方法-1 默认Dialog对话框左侧栏有桌面、我的文档等快捷方式，也比较符合一般人的使用习惯。
优点是，本层文件夹内的子文件夹全部以大图标方式列出（也可以改为列表）看起来较为轻松。
缺点是，如果有多层子文件夹，需要一层一层地点下去……似乎比较累一点。

与此相对、方法-2 是浏览器形式，点击+号可以展开、点击-号可以折叠。
因此也有很多人特别喜欢这一种的，尤其是有多层子文件夹时很方便。

  1. 仅列出目标文件夹中所有文件。（不包括 子文件夹、不包括子文件夹中的文件）
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub ListFilesTest()
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
    End With
    If Right(myPath, 1) <> "" Then myPath = myPath & ""
    '以上选择目标文件夹以得到路径myPath

    MsgBox ListFiles(myPath)    '调用FSO的ListFiles过程返回目标文件夹下的所有文件名
    
End Sub

Function ListFiles(myPath$)
   Set fso = CreateObject("Scripting.FileSystemObject") '打开FSO脚本、建立FSO对象实例
   For Each f In fso.GetFolder(myPath).Files  '用FSO方法遍历指定文件夹内所有文件
      i = i + 1: s = s & vbCr & f.Name            '逐个列出文件名并统计文件个数 i
   Next
   ListFiles = i & " Files:" & s  '返回所有文件名的合并字符串
End Function

知识介绍：
Set fso = CreateObject(“Scripting.FileSystemObject”)
建立FSO 即【文件系统对象】的实例。

这以后，即可简单、直接地引用fso的各种属性（有时间可以自己慢慢研究）

For Each f In fso.GetFolder(myPath).Files
‘用FSO方法遍历指定文件夹内所有文件

fso.GetFolder(myPath) 是指对于路径myPath，使用FSO对象方法得到其文件夹.GetFolder属性
然后，对于这个指定的目标文件夹，继续返回其所有文件的属性、即.Files
完整的部分为： fso.GetFolder(myPath).Files

然后，对于这个所有文件的集合即 fso.GetFolder(myPath).Files
通过For……Each循环就可以遍历其中每一个文件了。

具体地，For Each f In 中的f变量，即为每一个文件。
循环中，可以使用f的各种属性。 f.Name只是其中的一种属性=文件名。

  1. 仅列出目标文件夹中所有子文件夹名。（不包括目标文件夹中文件、不包括子文件夹中的文件或子文件夹）
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub ListFilesTest()
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
    End With
    If Right(myPath, 1) <> "" Then myPath = myPath & ""
    
    MsgBox ListFolders(myPath)
    
End Sub
Function ListFolders(myPath$)
   Set fso = CreateObject("Scripting.FileSystemObject")
   For Each f In fso.GetFolder(myPath).SubFolders
      j = j + 1: t = t & vbCr & f.Name
   Next
   ListFolders = j & " Folders:" & t
End Function

和楼上的代码ListFiles相比，差异很小，仅在于：
fso.GetFolder(myPath).Files
fso.GetFolder(myPath).SubFolders

即，把目标文件夹fso.GetFolder(myPath)的属性，
有.Files 所有文件、改为 .SubFolders 所有子文件夹

  1. 遍历目标文件夹内所有文件、以及所有子文件夹中的所有文件
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Sub ListFilesTest()
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
    End With
    If Right(myPath, 1) <> "" Then myPath = myPath & ""
    
    [a:a] = ""                    '清空A列
    Call ListAllFso(myPath)   '调用FSO遍历子文件夹的递归过程
    
End Sub

Function ListAllFso(myPath$) '用FSO方法遍历并列出所有文件和文件夹名的【递归过程】
    Set fld = CreateObject("Scripting.FileSystemObject").GetFolder(myPath)
    '用FSO方法得到当前路径的文件夹对象实例 注意这里的【当前路径myPath是个递归变量】

    For Each f In fld.Files  '遍历当前文件夹内所有【文件.Files】
        [a65536].End(3).Offset(1) = f.Name '在A列逐个列出文件名
    Next

    For Each fd In fld.SubFolders  '遍历当前文件夹内所有【子文件夹.SubFolders】
        [a65536].End(3).Offset(1) = " " & fd.Name & ""  '在A列逐个列出子文件夹名
        Call ListAllFso(fd.Path)       '注意此时的路径变量已经改变为【子文件夹的路径fd.Path】
        '注意重点在这里： 继续向下调用递归过程【遍历子文件夹内所有文件文件夹对象】
    Next
End Function

由于很多初学者不太能理解递归算法的过程而产生畏难、抵触情绪，
所以下面避开递归，而采用字典记录中间结果的方法，同样来达到遍历所所有子文件的目的(不过个人觉得还不如递归呢)：

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Sub ListFilesTest()
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
    End With
    If Right(myPath, 1) <> "" Then myPath = myPath & ""
    
    MsgBox "List Files:" & vbCr & Join(ListAllFsoDic(myPath), vbCr)
    MsgBox "List SubFolders:" & vbCr & Join(ListAllFsoDic(myPath, 1), vbCr)
End Sub

Function ListAllFsoDic(myPath$, Optional k = 0) '使用2个字典但无需递归的遍历过程
    Dim i&, j&
    Set d1 = CreateObject("Scripting.Dictionary") '字典d1记录子文件夹的绝对路径名    
    Set d2 = CreateObject("Scripting.Dictionary") '字典d2记录文件名 （文件夹和文件分开处理）

    d1(myPath) = ""           '以当前路径myPath作为起始记录，以便开始循环检查
 
    Set fso = CreateObject("Scripting.FileSystemObject")
    Do While i < d1.Count
    '当字典1文件夹中有未遍历处理的key存在时进行Do循环 直到 i=d1.Count即所有子文件夹都已处理时停止

        kr = d1.Keys '取出文件夹中所有的key即所有子文件夹路径 （注意每次都要更新）
        For Each f In fso.GetFolder(kr(i)).Files '遍历该子文件夹中所有文件 （注意仅从新的kr(i) 开始）
            j = j + 1: d2(j) = f.Name
           '把该子文件夹内的所有文件名作为字典Item项加入字典d2 (为防止文件重名不能用key属性)
        Next

        i = i + 1 '已经处理过的子文件夹数目 i +1 （避免下次产生重复处理）
        For Each fd In fso.GetFolder(kr(i - 1)).SubFolders '遍历该文件夹中所有新的子文件夹
            d1(fd.Path) = " " & fd.Name & "" 
            '把新的子文件夹路径存入字典d1以便在下一轮循环中处理
        Next
    Loop

    If k Then ListAllFsoDic = d1.Keys Else ListAllFsoDic = d2.Items
    '如果参数=1则列出字典d1中所有子文件夹的路径名 (如使用d1.Items则仅列出子文件夹名称不含路径)
    '如果参数=0则默认列出字典d2中Items即所有文件名 

End Function
  1. 作为本帖的特色，介绍使用VBA语句直接调用Dos中Dir命令来搜寻文件名的方法：(个人感觉不如FSO)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub ListFilesDos()
    Set myFolder = CreateObject("Shell.Application").BrowseForFolder(0, "GetFolder", 0)
    If Not myFolder Is Nothing Then myPath$ = myFolder.Items.Item.Path Else MsgBox "Folder not Selected": Exit Sub
    
    myFile$ = InputBox("Filename", "Find File", ".xl")
    '在这里输入需要指定的关键字，可以是文件名的一部分，或指定文件类型如 ".xl"
    tms = Timer
    With CreateObject("Wscript.Shell") 'VBA调用Dos命令
        ar = Split(.exec("cmd /c dir /a-d /b /s " & Chr(34) & myPath & Chr(34)).StdOut.ReadAll, vbCrLf) '所有文档含子文件夹
        '指定Dos中Dir命令的开关然后提取结果 为指定文件夹以及所含子文件夹内的所有文件的含路径全名。
        s = "from " & UBound(ar) & " Files by Search time: " & Format(Timer - tms, " 0.00s") & " in: " & myPath
        '记录Dos中执行Dir命令的耗时
        tms = Timer: ar = Filter(ar, myFile) '然后开始按指定关键词进行筛选。可筛选文件名或文件类型
        Application.StatusBar = Format(Timer - tms, "0.00s") & " Find " & UBound(ar) + IIf(myFile = "", 0, 1) & " Files " & s
        '在Excel状态栏上显示执行结果以及耗时
    End With
    [a:a] = "": If UBound(ar) > -1 Then [a2].Resize(1 + UBound(ar)) = WorksheetFunction.Transpose(ar)
    '清空A列，然后输出结果
End Sub

呵呵，Dos命令不仅简洁，而且高效。

追加更正：提去文件个数统计 提取文件结果的数组ar是下标 0开始的1维数组，元素个数应该=UBound(ar)+1 【此处修正+1为ar(0)】 但实际未产生筛选时的文件结果数=UBound(ar) 无需+1 【因为Dos提取时Dir最后1个””也在结果之中】 而当指定筛选参数myFile不为空时，即产生实际筛选以后的数组ar中会排除最后的那个””,所以筛选后的统计文件结果数=UBound(ar) + 1

关于Dos中Dir命令的开关问题：

【提取文档】
.Exec(“cmd /c dir /a-d /b “ ………Dir返回指定文件夹下【不包括子文件夹】的所有文档名（不含文件夹）
.Exec(“cmd /c dir /a-d /b /s “ ………Dir返回指定文件夹下【包括子文件夹】在内的所有文档名（不含文件夹）

其中， /s 即 是否包含 SubFolder的意思
而 /a-d 是文件对象中排除文件夹目录(-d)只剩下文档的意思。

【提取文件夹】
.Exec(“cmd /c dir /a-a /b “ ………Dir返回指定文件夹下【不包括子文件夹】内的所有子文件夹名（不含文档）
.Exec(“cmd /c dir /a-a /b /s “ ………Dir返回指定文件夹下【包括子文件夹】内的所有子文件夹名（不含文档）
而 /a-a 是文件对象中排除文档(-a)只剩下文件夹目录的意思。

【提取文档和文件夹】
.Exec(“cmd /c dir /b “ ………Dir返回指定文件夹下【不包括子文件夹】的所有【文档名】和【文件夹名】
.Exec(“cmd /c dir /b /s “ ………Dir返回指定文件夹下【包括子文件夹】的所有【文档名】和【文件夹名】

呵呵，以上6种的开关组合就足够了。
补充：Dos Dir开关的帮助文件：

显示目录中的文件和子目录列表。

DIR [drive:][path][filename] [/A[[:]attributes]] [/B] [/C] [/D] [/L] [/N]
[/O[[:]sortorder]] [/P] [/Q] [/S] [/T[[:]timefield]] [/W] [/X] [/4]

[drive:][path][filename]
指定要列出的驱动器、目录和/或文件。

/A 显示具有指定属性的文件。
attributes D 目录 R 只读文件
H 隐藏文件 A 准备存档的文件
S 系统文件 - 表示“否”的前缀
/B 使用空格式(没有标题信息或摘要)。
/C 在文件大小中显示千位数分隔符。这是默认值。用 /-C 来
停用分隔符显示。
/D 跟宽式相同，但文件是按栏分类列出的。
/L 用小写。
/N 新的长列表格式，其中文件名在最右边。
/O 用分类顺序列出文件。
sortorder N 按名称(字母顺序) S 按大小(从小到大)
E 按扩展名(字母顺序) D 按日期/时间(从先到后)
G 组目录优先 - 颠倒顺序的前缀
/P 在每个信息屏幕后暂停。
/Q 显示文件所有者。
/S 显示指定目录和所有子目录中的文件。
/T 控制显示或用来分类的时间字符域。
timefield C 创建时间
A 上次访问时间
W 上次写入的时间
/W 用宽列表格式。
/X 显示为非 8dot3 文件名产生的短名称。格式是 /N 的格式，
短名称插在长名称前面。如果没有短名称，在其位置则
显示空白。
/4 用四位数字显示年

可以在 DIRCMD 环境变量中预先设定开关。通过添加前缀 - (破折号)
来替代预先设定的开关。例如，/-W。

前面的Dir代码，是两个Do循环嵌套使用，
一边检查当前文件夹内的子文件夹，一边检查当前文件夹内的文件。

其实，Dir方法也可以这么写代码：
① 检查并列出所有子文件夹
② 然后根据需要遍历所有子文件夹中的文件

即，两个Do循环是分开来的。
但是、第2次的Do循环需要外套For循环遍历所有已知子文件夹。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
Sub ListFilesDir()
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
    End With
    If Right(myPath, 1) <> "" Then myPath = myPath & ""
    
    MsgBox Join(ListAllDir(myPath), vbCr) 'GetAllSubFolder's File
    MsgBox Join(ListAllDir(myPath, 1), vbCr) 'GetThisFolder's File
    
    MsgBox Join(ListAllDir(myPath, -1), vbCr) 'GetThisFolder's SubFolder
    MsgBox Join(ListAllDir(myPath, -2), vbCr) 'GetAllSubFolder
    
    MsgBox Join(ListAllDir(myPath, , "tst"), vbCr) 'GetAllSubFolder's SpecialFile
    MsgBox Join(ListAllDir(myPath, 1, "tst"), vbCr) 'GetThisFolder's SpecialFile
End Sub

Function ListAllDir(myPath$, Optional sb& = 0, Optional SpFile$ = "")
    Dim i&, j&, k&, myFile$
    ReDim fld(0)
    
    fld(0) = myPath
    On Error Resume Next
    Do
        myFile = Dir(fld(i), vbDirectory)
        Do While myFile <> ""
            If myFile <> "." And myFile <> ".." Then
                If (GetAttr(fld(i) & myFile) And vbDirectory) = vbDirectory Then
                    If Err.Number Then Err.Clear Else j = j + 1: ReDim Preserve fld(j): fld(j) = fld(i) & myFile & ""
                End If
            End If
            myFile = Dir
        Loop
        If sb Mod 2 Then Exit Do Else i = i + 1
    Loop Until i > UBound(fld)
    If sb < 0 And Len(SpFile) = 0 Then ListAllDir = fld: Exit Function
    '以上为止，遍历检查并列出指定目标文件夹中、所有的子文件夹。
    
    '以下为遍历已获得的子文件夹数组fld 然后Dir循环检查其中所有的文件
    ReDim file(0)
    For i = 0 To UBound(fld)
        myFile = Dir(fld(i), vbDirectory)
        Do While myFile <> ""
            If myFile <> "." And myFile <> ".." Then
                If Not (GetAttr(fld(i) & myFile) And vbDirectory) = vbDirectory Then
                    If SpFile = "" Then
                        file(k) = myFile: k = k + 1: ReDim Preserve file(k)
                    Else
                        If InStr(myFile, SpFile) Then file(k) = myFile: k = k + 1: ReDim Preserve file(k)
                    End If
                End If
            End If
            myFile = Dir
        Loop
    Next
    ListAllDir = file
End Function

一般说，还是第1种两个Do嵌套的方法好……虽然代码中需要同时处理文件夹和文件名，但Do循环比较高效一些。

第2种方法也并非全无是处。
当处理文件为重点时，以第2种方法比较好。

Dos版 加入Dir各种参数以后的完整代码：

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Sub ListFilesDos()
    myMode& = Val(InputBox("Search Mode:-3 To 3", "Find File", 0)) '指定Dos Dir的查找开关、返回模式
    '奇数为不含子文件夹、偶数为含子文件夹 / 负数为目录、正数为文档 / >1为文档及目录
    
    If myMode > -3 Then
        myFile$ = InputBox("Part of Filename or Filetype as "".xl""", "Find File", ".xl")
        '输入指定关键字，可以是文件(文档和目录)名称中的任意部分，或指定文件类型如 ".xl"
    
        Set myFolder = CreateObject("Shell.Application").BrowseForFolder(0, "GetFolder", 0)
        If Not myFolder Is Nothing Then myPath$ = myFolder.Items.Item.path Else MsgBox "Folder not Selected": Exit Sub
        '浏览列表指定查找目录
    End If
    tms = Timer
    With CreateObject("Wscript.Shell") 'VBA调用Dos命令
　　cmdStr = Choose(myMode + 4, "/? ", "/a:d /b /s ", "/a:d /b ", "/a:a /b /s ", "/a:a /b ", "/b /s ", "/b ", "/a:a /o:e /o:n /s ", "/a:a /o:e /o:n ", "/a:d /o:e /o:n /s ", "/a:d /o:e /o:n ")
        ar = Split(.exec("cmd /c dir " & cmdStr & Chr(34) & myPath & Chr(34)).StdOut.ReadAll, vbCrLf)
        '指定Dos中Dir命令的开关然后提取结果 为指定文件夹以及所含子文件夹内的所有文件的含路径全名。
        
        s = UBound(ar) & " Files by Search time: " & Format(Timer - tms, " 0.00s") & " in: " & myPath
        Application.StatusBar = " Find " & s: tms = Timer '记录Dos中执行Dir命令的耗时 并在Excel状态栏上显示
        If myFile <> "" Then '如指定了匹配关键字则
            ar = Filter(ar, myFile) '按指定关键词myFile进行筛选。可筛选文件名或文件类型、然后在Excel状态栏上显示结果
            Application.StatusBar = Format(Timer - tms, "0.00s") & " Find " & 1 + UBound(ar) & " Files from " & s
        End If
    End With
    [a:a] = "": If UBound(ar) > -1 Then [a2].Resize(1 + UBound(ar)) = WorksheetFunction.Transpose(ar)
'    清空A列，然后输出结果
End Sub

为大家看得清楚明白，把各种开关写成Select形式：

​ Select Case myMode ‘根据开关模式设置Dos Dir的开关参数
​ Case -3
​ cmdStr = “cmd /c dir /?” ‘列出Dir各个参数开关的帮助文件
​ Case -2
​ cmdStr = “cmd /c dir /a-a /b /s “ & Chr(34) & myPath & Chr(34) ‘目录不含文档[/a-a]含子文件夹
​ Case -1
​ cmdStr = “cmd /c dir /a-a /b “ & Chr(34) & myPath & Chr(34) ‘目录不含文档/a-a
​ Case 0
​ cmdStr = “cmd /c dir /a-d /b /s “ & Chr(34) & myPath & Chr(34) ‘文档不含目录[/a-d]含子文件夹
​ Case 1
​ cmdStr = “cmd /c dir /a-d /b “ & Chr(34) & myPath & Chr(34) ‘文档不含目录/a-d
​ Case 2
​ cmdStr = “cmd /c dir /b /s “ & Chr(34) & myPath & Chr(34) ‘所有文档及目录含子文件夹
​ Case 3
​ cmdStr = “cmd /c dir /a-d /b “ & Chr(34) & myPath & Chr(34) ‘所有文档及目录(不含子文件夹)
​ End Select

但实际代码中用Choose语句简化。

  1. FSO 递归方法实现各种指定搜寻的完整代码：
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48

Dim jg(), k&, tms# '因为是递归，所以事先指定存放结果的公用变量数组jg以及计数器k和起始时间tms
Sub ListFilesFso()
    sb& = InputBox("Search Type: AllFiles=0/Files=1/Folder=-1/All Folder=-2", "Find Files", 0) '选定返回模式
    SpFile$ = InputBox("匹配文件名或文件类型", "Find Files", ".xl") '指定匹配要求，留空则匹配全部
    If SpFile Like ".*" Then SpFile = LCase(SpFile) & "*" '如果指定了文件类型则一律转换为大写字母方便比较
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then myPath$ = .SelectedItems(1) Else Exit Sub
    End With
    If Right(myPath, 1) <> "" Then myPath = myPath & ""
    
    ReDim jg(65535, 3)
    jg(0, 0) = "Ext": jg(0, 1) = IIf(sb < 0, IIf(Len(SpFile), "Filename", "No"), "Filename")
    jg(0, 2) = "Folder": jg(0, 3) = "Path"
    '定义存放文件名结果的数组jg 、并写入标题
    tms = Timer: k = 0: Call ListAllFso(myPath, sb, SpFile) '调用递归过程检查指定文件夹及其子文件夹
    If sb < 0 And Len(SpFile) = 0 Then Application.StatusBar = "Get " & k & " Folders."
    [a1].CurrentRegion = "": [a1].Resize(k + 1, 4) = jg: [a1].CurrentRegion.AutoFilter Field:=1
    '输出结果到工作表，并启用筛选模式
End Sub

Function ListAllFso(myPath$, Optional sb& = 0, Optional SpFile$ = "") '递归检查子文件夹的过程代码
    Set fld = CreateObject("Scripting.FileSystemObject").GetFolder(myPath)
    On Error Resume Next
    If sb >= 0 Or Len(SpFile) Then '如果模式为0或1、或指定了匹配文件要求，则遍历各个文件
        For Each f In fld.Files '用FSO方法遍历文件.Files
            t = False '匹配状态初始化
            n = InStrRev(f.Name, "."): fnm = Left(f.Name, n - 1): x = LCase(Mid(f.Name, n))
            If Err.Number Then Err.Clear
            
            If SpFile = " " Then 'Space 如果匹配要求为空则匹配全部
                t = True
            ElseIf SpFile Like ".*" Then '如果匹配要求为文件类型则
                If x Like SpFile Then t = True '当文件符合文件类型要求时匹配，否则不匹配
            Else '否则为需要匹配文件名称中的一部分
                If InStr(fnm, SpFile) Then t = True '如果匹配则状态为True
            End If
            If t Then k = k + 1: jg(k, 0) = x: jg(k, 1) = "'" & fnm: jg(k, 2) = fld.Name: jg(k, 3) = fld.Path
        Next
        Application.StatusBar = Format(Timer - tms, "0.0s") & " Get " & k & " Files , Searching in Folder ... " & fld.Path
    End If
    
    For Each fd In fld.SubFolders '然后遍历检查所有子文件夹.SubFolders
        If sb < 0 And Len(SpFile) = 0 Then k = k + 1: jg(k, 0) = "fld": jg(k, 1) = k: jg(k, 2) = fd.Name: jg(k, 3) = fld.Path
        If sb Mod 2 = 0 Then Call ListAllFso(fd.Path, sb, SpFile)
    Next
End Function
  1. 定义的写法——补课

关于变量类型缩写的快速记忆：

! = Single 单精度小数……因为 ! 笔画只是1竖单笔画，所以记住为【单精度】
# = Double 双精度小数 …因为 # 笔画是2横2竖，所以记住为【双精度】
@ = Currency 货币型4位小数 …现实中大家也常用@符号代表价格、单价，所以记住为【货币型小数】
$ = String 文本字符串 …因为 String第1个字母是 S 所以记住为【美元s=String 文本字符串】

% = Integer 整数 ……因为 % 是百分比符号我们把它联想为较少的整数【整型数值】
& = Long 整数 ……因为 & 可以看做是Long首字母L的花体字 所以记住为【长整型数值】

呵呵，这样稍稍动脑筋记忆一下，以后就可以简单使用了。
比如这样子：
Dim i&, j&, k&, l&, l1&, l2&, m&, n&, s$, w1$, w2$

如果很正规地写，成为：
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim l1 As Long
Dim l2 As Long
Dim m As Long
Dim n As Long

Dim s As String
Dim w1 As String
Dim w2 As String

这样就会很长。

或者写在一起时，横向会很长也不方便
Dim i As Long, j As Long, k As Long, l As Long, l1 As Long, l2 As Long, m As Long, n As Long
Dim s As String, w1 As String, w2 As String

…………
以上只是个人习惯而已。

但是，新手千万不要这样子：
Dim i, j, k, l, l1, l2, m, n As Long
Dim s, w1, w2 As String

这样做，只有最后一个蓝色的变量被正确定义了变量类型，
其它的都会被作为Variant变量使用……或许不影响使用，但至少违背了作者的初衷。所以不好。

如果需要操作文件以及文件内的各个工作表Sheet，那么当然首先要打开该文件。

1
2
3
4
5
6
7
8
9
10
11
Function ListFiles(myPath$)
   Set Fso = CreateObject("Scripting.FileSystemObject")
   For Each f In Fso.GetFolder(myPath).Files
      Workbooks.Open (f) '打开文件
      For Each sh In ActiveWorkbook.Sheets '遍历该文件的所有工作表
        sh.Activate '激活工作表
        
      Next
      ActiveWorkbook.Close '关闭文件
   Next
End Function

【Dir 使用方法】

myPath = “c:" ‘首先设定目标文件夹，注意末尾必须是【\】文件夹符号。

myFile = Dir(myPath, vbDirectory) ‘第一次使用Dir函数时，必须完整输入路径和检索要求。
‘ 如果直接使用Dir不带参数则会报错。

Do While myFile <> “” ‘开始Do不定循环、直至在本文件夹内没有找到文档/文件夹而返回空白时停止。

If myFile <> “.” And myFile <> “..” Then
‘此If判断为忽略 当前文件夹”.”以及忽略上级文件夹”..”

​ If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
​ ‘接下来的If判断是：通过二进制的位比较计算结果= vbDirectory 来判断这是一个文件夹。
​ Debug.Print myFile ‘判断为文件夹时的处理
​ Else ‘否则为文档
​ Debug.Print myFile ‘判断为文档时的处理。
​ End If
End If
myFile = Dir ‘继续调用【不带路径参数的Dir函数】 这样就能得到下一个搜寻结果。
Loop

四、本人的代码

  1. 之前平浙信项目折腾从excel到word，批量替换多个变量，遍历文件夹，但是开始自己还不会，只好在代码内复制粘贴，主要是为了满足功能，就这已经帮我们团队节省了80%以上的人力，先把丑陋的代码放在这里，命名v1.1：
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
Private Sub CommandButton1_Click()

   Dim Word对象 As New Word.Application, 当前路径, 导出文件名, 导出路径文件名, i, j
   Dim Str1, Str2
   当前路径 = ThisWorkbook.Path
   最后行号 = Sheets("数据").Range("B65536").End(xlUp).Row
   判断 = 0
   For i = 3 To 最后行号
      导出文件名 = "信托合同：6份，每份骑缝章1各，签署页公章和法人章各1个，附件6预留印鉴公章和法人各1个"
      FileCopy 当前路径 & "\信托合同：6份，每份骑缝章1各，签署页公章和法人章各1个，附件6预留印鉴公章和法人各1个.doc", 当前路径 & "\" & 导出文件名 & "(" & Sheets("数据").Range("B" & i) & ").doc"
      导出路径文件名 = 当前路径 & "\" & 导出文件名 & "(" & Sheets("数据").Range("B" & i) & ").doc"
      With Word对象
        .Documents.Open 导出路径文件名
        .Visible = False
        .Selection.HomeKey Unit:=wdStory '光标置于文件首
        With .Selection.Find '填写文字数据
            For j = 1 To 48
             Str1 = "数据" & Format(j, "000")
             Str2 = Sheets("数据").Cells(i, j + 1)
             .Text = Str1
             .Replacement.Text = Str2 '替换字符串
             .Execute Replace:=wdReplaceAll '全部替换
            Next j
        End With
        .ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader '设置位置在页眉
        Str1 = "数据001"
        Str2 = Sheets("数据2").Cells(i, 2)
        .Selection.HomeKey Unit:=wdStory '光标置于文件首
        If .Selection.Find.Execute(Str1) Then '查找到指定字符串
           .Selection.Font.Color = wdColorAutomatic '字符为自动颜色
           .Selection.Text = Str2 '替换字符串
        End If
      End With
      Word对象.Documents.Save
      Word对象.Quit
      Set Word对象 = Nothing
   Next i
    
   For i = 3 To 最后行号
      导出文件名 = "本期区块链应收款清单：4份，总行公章+法人章+骑缝"
      FileCopy 当前路径 & "\本期区块链应收款清单：4份，总行公章+法人章+骑缝.doc", 当前路径 & "\" & 导出文件名 & "(" & Sheets("数据").Range("B" & i) & ").doc"
      导出路径文件名 = 当前路径 & "\" & 导出文件名 & "(" & Sheets("数据").Range("B" & i) & ").doc"
      With Word对象
        .Documents.Open 导出路径文件名
        .Visible = False
        .Selection.HomeKey Unit:=wdStory '光标置于文件首
        With .Selection.Find '填写文字数据
            For j = 1 To 48
             Str1 = "数据" & Format(j, "000")
             Str2 = Sheets("数据").Cells(i, j + 1)
             .Text = Str1
             .Replacement.Text = Str2 '替换字符串
             .Execute Replace:=wdReplaceAll '全部替换
            Next j
        End With
        .ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader '设置位置在页眉
        Str1 = "数据001"
        Str2 = Sheets("数据2").Cells(i, 2)
        .Selection.HomeKey Unit:=wdStory '光标置于文件首
        If .Selection.Find.Execute(Str1) Then '查找到指定字符串
           .Selection.Font.Color = wdColorAutomatic '字符为自动颜色
           .Selection.Text = Str2 '替换字符串
        End If
      End With
      Word对象.Documents.Save
      Word对象.Quit
      Set Word对象 = Nothing
   Next i
       
   For i = 3 To 最后行号
      导出文件名 = "风险说明书：6份，总行公章、法人章+骑缝"
      FileCopy 当前路径 & "\风险说明书：6份，总行公章、法人章+骑缝.doc", 当前路径 & "\" & 导出文件名 & "(" & Sheets("数据").Range("B" & i) & ").doc"
      导出路径文件名 = 当前路径 & "\" & 导出文件名 & "(" & Sheets("数据").Range("B" & i) & ").doc"
      With Word对象
        .Documents.Open 导出路径文件名
        .Visible = False
        .Selection.HomeKey Unit:=wdStory '光标置于文件首
        With .Selection.Find '填写文字数据
            For j = 1 To 48
             Str1 = "数据" & Format(j, "000")
             Str2 = Sheets("数据").Cells(i, j + 1)
             .Text = Str1
             .Replacement.Text = Str2 '替换字符串
             .Execute Replace:=wdReplaceAll '全部替换
            Next j
        End With
        .ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader '设置位置在页眉
        Str1 = "数据001"
        Str2 = Sheets("数据2").Cells(i, 2)
        .Selection.HomeKey Unit:=wdStory '光标置于文件首
        If .Selection.Find.Execute(Str1) Then '查找到指定字符串
           .Selection.Font.Color = wdColorAutomatic '字符为自动颜色
           .Selection.Text = Str2 '替换字符串
        End If
      End With
      Word对象.Documents.Save
      Word对象.Quit
      Set Word对象 = Nothing
   Next i
       
   For i = 3 To 最后行号
      导出文件名 = "信托说明书"
      FileCopy 当前路径 & "\信托说明书.doc", 当前路径 & "\" & 导出文件名 & "(" & Sheets("数据").Range("B" & i) & ").doc"
      导出路径文件名 = 当前路径 & "\" & 导出文件名 & "(" & Sheets("数据").Range("B" & i) & ").doc"
      With Word对象
        .Documents.Open 导出路径文件名
        .Visible = False
        .Selection.HomeKey Unit:=wdStory '光标置于文件首
        With .Selection.Find '填写文字数据
            For j = 1 To 48
             Str1 = "数据" & Format(j, "000")
             Str2 = Sheets("数据").Cells(i, j + 1)
             .Text = Str1
             .Replacement.Text = Str2 '替换字符串
             .Execute Replace:=wdReplaceAll '全部替换
            Next j
        End With
        .ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader '设置位置在页眉
        Str1 = "数据001"
        Str2 = Sheets("数据2").Cells(i, 2)
        .Selection.HomeKey Unit:=wdStory '光标置于文件首
        If .Selection.Find.Execute(Str1) Then '查找到指定字符串
           .Selection.Font.Color = wdColorAutomatic '字符为自动颜色
           .Selection.Text = Str2 '替换字符串
        End If
      End With
      Word对象.Documents.Save
      Word对象.Quit
      Set Word对象 = Nothing
   Next i
       
   For i = 3 To 最后行号
        导出文件名 = "资产服务协议：5份，总行公章、法人章+骑缝"
      FileCopy 当前路径 & "\资产服务协议：5份，总行公章、法人章+骑缝.doc", 当前路径 & "\" & 导出文件名 & "(" & Sheets("数据").Range("B" & i) & ").doc"
      导出路径文件名 = 当前路径 & "\" & 导出文件名 & "(" & Sheets("数据").Range("B" & i) & ").doc"
      With Word对象
        .Documents.Open 导出路径文件名
        .Visible = False
        .Selection.HomeKey Unit:=wdStory '光标置于文件首
        With .Selection.Find '填写文字数据
            For j = 1 To 48
             Str1 = "数据" & Format(j, "000")
             Str2 = Sheets("数据").Cells(i, j + 1)
             .Text = Str1
             .Replacement.Text = Str2 '替换字符串
             .Execute Replace:=wdReplaceAll '全部替换
            Next j
        End With
        .ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader '设置位置在页眉
        Str1 = "数据001"
        Str2 = Sheets("数据2").Cells(i, 2)
        .Selection.HomeKey Unit:=wdStory '光标置于文件首
        If .Selection.Find.Execute(Str1) Then '查找到指定字符串
           .Selection.Font.Color = wdColorAutomatic '字符为自动颜色
           .Selection.Text = Str2 '替换字符串
        End If
      End With
      Word对象.Documents.Save
      Word对象.Quit
      Set Word对象 = Nothing
   Next i
       
   For i = 3 To 最后行号
      导出文件名 = "资产交割确认书：5份，总行公章+法人章"
      FileCopy 当前路径 & "\资产交割确认书：5份，总行公章+法人章.doc", 当前路径 & "\" & 导出文件名 & "(" & Sheets("数据").Range("B" & i) & ").doc"
      导出路径文件名 = 当前路径 & "\" & 导出文件名 & "(" & Sheets("数据").Range("B" & i) & ").doc"
      With Word对象
        .Documents.Open 导出路径文件名
        .Visible = False
        .Selection.HomeKey Unit:=wdStory '光标置于文件首
        With .Selection.Find '填写文字数据
            For j = 1 To 25
             Str1 = "数据" & Format(j, "000")
             Str2 = Sheets("数据").Cells(i, j + 1)
             .Text = Str1
             .Replacement.Text = Str2 '替换字符串
             .Execute Replace:=wdReplaceAll '全部替换
            Next j
        End With
        .ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader '设置位置在页眉
        Str1 = "数据001"
        Str2 = Sheets("数据2").Cells(i, 2)
        .Selection.HomeKey Unit:=wdStory '光标置于文件首
        If .Selection.Find.Execute(Str1) Then '查找到指定字符串
           .Selection.Font.Color = wdColorAutomatic '字符为自动颜色
           .Selection.Text = Str2 '替换字符串
        End If
      End With
      Word对象.Documents.Save
      Word对象.Quit
      Set Word对象 = Nothing
   Next i
       
   For i = 3 To 最后行号
      导出文件名 = "交割确认函：5份，总行公章+法人章"
      FileCopy 当前路径 & "\交割确认函：5份，总行公章+法人章.doc", 当前路径 & "\" & 导出文件名 & "(" & Sheets("数据").Range("B" & i) & ").doc"
      导出路径文件名 = 当前路径 & "\" & 导出文件名 & "(" & Sheets("数据").Range("B" & i) & ").doc"
      With Word对象
        .Documents.Open 导出路径文件名
        .Visible = False
        .Selection.HomeKey Unit:=wdStory '光标置于文件首
        With .Selection.Find '填写文字数据
            For j = 1 To 25
             Str1 = "数据" & Format(j, "000")
             Str2 = Sheets("数据").Cells(i, j + 1)
             .Text = Str1
             .Replacement.Text = Str2 '替换字符串
             .Execute Replace:=wdReplaceAll '全部替换
            Next j
        End With
        .ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader '设置位置在页眉
        Str1 = "数据001"
        Str2 = Sheets("数据2").Cells(i, 2)
        .Selection.HomeKey Unit:=wdStory '光标置于文件首
        If .Selection.Find.Execute(Str1) Then '查找到指定字符串
           .Selection.Font.Color = wdColorAutomatic '字符为自动颜色
           .Selection.Text = Str2 '替换字符串
        End If
      End With
      Word对象.Documents.Save
      Word对象.Quit
      Set Word对象 = Nothing
   Next i

    
   For i = 3 To 最后行号
      导出文件名 = "信托收益权转让登记表：3份，总行公章"
      FileCopy 当前路径 & "\信托收益权转让登记表：3份，总行公章.doc", 当前路径 & "\" & 导出文件名 & "(" & Sheets("数据").Range("B" & i) & ").doc"
      导出路径文件名 = 当前路径 & "\" & 导出文件名 & "(" & Sheets("数据").Range("B" & i) & ").doc"
      With Word对象
        .Documents.Open 导出路径文件名
        .Visible = False
        .Selection.HomeKey Unit:=wdStory '光标置于文件首
        With .Selection.Find '填写文字数据
            For j = 1 To 25
             Str1 = "数据" & Format(j, "000")
             Str2 = Sheets("数据").Cells(i, j + 1)
             .Text = Str1
             .Replacement.Text = Str2 '替换字符串
             .Execute Replace:=wdReplaceAll '全部替换
            Next j
        End With
        .ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader '设置位置在页眉
        Str1 = "数据001"
        Str2 = Sheets("数据2").Cells(i, 2)
        .Selection.HomeKey Unit:=wdStory '光标置于文件首
        If .Selection.Find.Execute(Str1) Then '查找到指定字符串
           .Selection.Font.Color = wdColorAutomatic '字符为自动颜色
           .Selection.Text = Str2 '替换字符串
        End If
      End With
      Word对象.Documents.Save
      Word对象.Quit
      Set Word对象 = Nothing
   Next i
  
   For i = 3 To 最后行号
      导出文件名 = "信托资金保管合同"
      FileCopy 当前路径 & "\信托资金保管合同.doc", 当前路径 & "\" & 导出文件名 & "(" & Sheets("数据").Range("B" & i) & ").doc"
      导出路径文件名 = 当前路径 & "\" & 导出文件名 & "(" & Sheets("数据").Range("B" & i) & ").doc"
      With Word对象
        .Documents.Open 导出路径文件名
        .Visible = False
        .Selection.HomeKey Unit:=wdStory '光标置于文件首
        With .Selection.Find '填写文字数据
            For j = 1 To 25
             Str1 = "数据" & Format(j, "000")
             Str2 = Sheets("数据").Cells(i, j + 1)
             .Text = Str1
             .Replacement.Text = Str2 '替换字符串
             .Execute Replace:=wdReplaceAll '全部替换
            Next j
        End With
        .ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader '设置位置在页眉
        Str1 = "数据001"
        Str2 = Sheets("数据2").Cells(i, 2)
        .Selection.HomeKey Unit:=wdStory '光标置于文件首
        If .Selection.Find.Execute(Str1) Then '查找到指定字符串
           .Selection.Font.Color = wdColorAutomatic '字符为自动颜色
           .Selection.Text = Str2 '替换字符串
        End If
      End With
      Word对象.Documents.Save
      Word对象.Quit
      Set Word对象 = Nothing
   Next i
   For i = 3 To 最后行号
      导出文件名 = "财产权受益权转让合同：5份，总行公章、法人章_骑缝"
      FileCopy 当前路径 & "\财产权受益权转让合同：5份，总行公章、法人章_骑缝.doc", 当前路径 & "\" & 导出文件名 & "(" & Sheets("数据").Range("B" & i) & ").doc"
      导出路径文件名 = 当前路径 & "\" & 导出文件名 & "(" & Sheets("数据").Range("B" & i) & ").doc"
      With Word对象
        .Documents.Open 导出路径文件名
        .Visible = False
        .Selection.HomeKey Unit:=wdStory '光标置于文件首
        With .Selection.Find '填写文字数据
            For j = 1 To 25
             Str1 = "数据" & Format(j, "000")
             Str2 = Sheets("数据").Cells(i, j + 1)
             .Text = Str1
             .Replacement.Text = Str2 '替换字符串
             .Execute Replace:=wdReplaceAll '全部替换
            Next j
        End With
        .ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader '设置位置在页眉
        Str1 = "数据001"
        Str2 = Sheets("数据2").Cells(i, 2)
        .Selection.HomeKey Unit:=wdStory '光标置于文件首
        If .Selection.Find.Execute(Str1) Then '查找到指定字符串
           .Selection.Font.Color = wdColorAutomatic '字符为自动颜色
           .Selection.Text = Str2 '替换字符串
        End If
      End With
      Word对象.Documents.Save
      Word对象.Quit
      Set Word对象 = Nothing
   Next i
   
   If 判断 = 0 Then
      i = MsgBox("已输出到 Word 文件！", 0 + 48 + 256 + 0, "提示：")
   End If
End Sub
Private Sub CommandButton输出通知到Word文件_Click()

End Sub
  1. 恰好这次有个客户反馈word模板目录有问题，于是经过几天李笑来老师的自学之书的指点，加上对python的进一步理解，对编程算是有了一点点进步，结合前面几位牛人的代码，我算是完成了代码的升级，所以命名2.0，代码如下：
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
Private Sub CommandButton1_Click()

    Dim Str1, Str2
    Dim j
    Dim wdApp As Word.Application
    
    Set myFolder = CreateObject("Shell.Application").BrowseForFolder(0, "GetFolder", 0)
    If Not myFolder Is Nothing Then myPath$ = myFolder.Items.Item.Path Else MsgBox "Folder not Selected": Exit Sub
    If Right(myPath, 1) <> "" Then myPath = myPath & ""
    '同样返回的是选中目标文件夹的绝对路径,但除了本地C盘、D盘会以"C:"形式返回外，其余路径无""需要添加
    判断 = 0
    Application.ScreenUpdating = False
    
    Set fld = CreateObject("Scripting.FileSystemObject").GetFolder(myPath) '设置FSO实例
       
    For Each f In fld.files '遍历文件夹
     '以下代码实现每个文件的查找替换
        Set wdApp = New Word.Application
        If Right(f.Name, 4) = ".doc" And InStr(f.Name, "$") = 0 Then
        With wdApp
            .Documents.Open (f) '打开文件，进行操作
            .Visible = False
            .Selection.HomeKey Unit:=wdStory '光标置于文件首
            With .Selection.Find '填写文字数据
                For j = 1 To 49
                    Str1 = "数据" & Format(j, "000")
                    Str2 = Sheets("数据").Cells(3, j + 1)
                    .Text = Str1
                    .Replacement.Text = Str2 '替换字符串
                    .Execute Replace:=wdReplaceAll '全部替换
                Next j
            End With
        
            .ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader '设置位置在页眉
                Str1 = "数据001"
                Str2 = Sheets("数据2").Cells(3, 2)
                .Selection.HomeKey Unit:=wdStory '光标置于文件首
      
                 If .Selection.Find.Execute(Str1) Then '查找到指定字符串
                    .Selection.Text = Str2 '替换字符串
                 End If
             
            .Documents.Save
            .Quit
        End With
        End If
        Set wdApp = Nothing
    Next
    Application.ScreenUpdating = True
    If 判断 = 0 Then
        i = MsgBox("已输出到 Word 文件！", 0 + 49 + 256 + 0, "提示：")
    End If
End Sub
Private Sub CommandButton输出通知到Word文件_Click()

End Sub
  1. 继续优化 代码，实现通用的批量查找替换

其实很容易，就把上面代码第26行修改为如下即可：

1
Str1 = Sheets("数据").Cells(2, j + 1)

修改后的使用方法：

  1. 选择需要批量替换的文件夹
  2. 注意指定文档为.doc的文档，这个可以通过修改代码来改为所有文件
  3. 在excel输入项里，第二行填写旧信息，第三行填写需要替换的信息
  4. 点击按钮即可，设置最多的是49项，可以通过修改代码增加或减少

2017-05-03-开篇

layout: post
title: 钞票搬运工博客开篇
subtitle: 开篇大吉
date: 2017-05-03
author: ZYC
header-img: img/post-bg-ios9-web.jpg
catalog: true
tags:
- 开篇
- 理财
- 财富

#钞票搬运工

##–开篇

今日凌晨，细思昨天跟朋友的各种细节，突然发出一个奇想，如果我利用自己对于产品的专业度，对于金融的深度理解，利用自己网站和微信公众号，发布产品信息和宣传软文，增加订阅量，也是一个很不错的注意哦。为此，我都给我的网站起好了名字，名字就叫做“钞票搬运工”。

内容板块我也想好了，初步就三个:

一个关于近期市场利率水平，理财最新动态，给客户一个基本服务；

第二块就是固收，把主要在售的几个产品，分别用简洁专业的语言介绍；

第三块就是其他公司产品，或者我代理的产品（未来也可以修改为权益类产品等）

我的优势在哪里：

＊对产品熟悉，专业！

＊懂写作，懂销售的重要性！

＊懂Linux和Python，今后利用爬虫分析理财产品！

＊可以通过微信公众号和个人专业网站宣传产品，提供服务！

＊前几年做项目的过程中，已经积累了一些高净值客户，这是我的竞争力！

我的劣势是什么：

＊不太善于跟人打交道。

＊内心深处我是看不起销售的。

不过这一次，经过这个朋友深入浅出的说服，我第一次认真的考虑转行做销售，考虑好好利用自身资源，考虑更近一步接近钱。还是那句话：“离钱近，离事远，离是非更远！”

所以，今天我用vim写下钞票搬运工的开篇，并且从此开启我的销售人生！

赵翀的诗

20200408

昨天赵翀又写了一首诗，还挺有些哲理性呢。昨晚上太忙了，今天补充记录一下《光与影》：

光代表光明
影代表黑暗
它俩是完全相反的存在
哪里有暗
哪里就有光
哪里有光
哪里就有暗
配图在此

今天写了三首诗：
星空（其一）
赵翀
星空是黑的，是亮晶晶的
也是又黑又亮晶晶的
当你打着雨伞，在雨中漫步
当你抬起头
也许你还忘不了
星空那美丽的夜色
当一道流星从夜色中飞过来
好像一个美丽的心愿
在我眼前飞过
当早晨的第一丝阳光升起
星空像飞鸟一样
飞到这里这里
又飞到那里……

星空（其二）
赵翀

又是一个安静、舒适、美好的夜晚
星空又慢慢的升起
将那柔和又微小的光芒
洒向大地

这时候
森林里的动物们
抬起头来
望着一闪一闪的星空

河里的鱼儿
仿佛停下来
望着河边倒映的星空

当又一个清晨升起
星空依然不忘
她那迷人的微笑
悄悄地离去……

山
赵翀

当你走出草屋
看向远远的天边
你，看到了什么？
你，看到的当然是高高的大山

大山
是创世巨人盘古的手臂
支撑着天空

山的肚子里装了森林、小溪、动物

夜晚
山抬起头
微笑着望着月亮小船
看着布满天空的星星

十年财务自由之路——投资实证#1

昨天晚上跟老婆说，今天已经完成了十年财务自由之路的初始化，每个月我们能够又3.5万的本金投入，每年也就是40万多的投入，坚持十年，就可以实现本金700万的目标，按10%的收益率计算，可以覆盖目前家庭所有开支，初步实现财务自由。

老婆大人昨天一直到8点半才下班，累的不行，我刚刚说完这几句话，她就开始不高兴了。过去的这些年，我们没有任何不必要的花费，我们已经是非常节俭了，难道还要更加节俭吗？我们还有哪些地方可以节省的呢？

昨天我在文章中其实也写了，我们一直比较节俭，这几年积蓄一点儿钱就去买房，平日里根本就没有太多不该的花费；而且收入来源主要就是工资，靠两个人的工作收入一点点积累，已经很辛苦，很累了。

而且，按照过往的做法，未来十年就算没有现在我所说的十年财务自由计划，只要是还像现在这样，努力工作，日常生活，我们依然也不会缺钱花，大概率事件，我们的生活水准在中上档，看看我们的同事，我们的前辈就知道了，没有多少是缺钱的。所以，我老婆的结论是，看不出我这个所谓十年财务自由之路的计划，有什么特别吸引人之处。

所以，昨天和今天一直都在思考这个问题。我的十年财务自由之路，重点应该不是减支和增收，积累本金，坚持长线投资，实现复利的魔力，才是重点。

持续积累本金

按过往一样，保持稳定的工作，积极努力的工作，赚取应有的工资报酬，累积本金。减支没有空间了，将来可以花费精力，在增收上面做做文章。

坚持长线投资

长线投资，这是我首先要努力坚持的，是未来应该努力的第一个重要方面。

过往的那些年，除了家里买的房子，都选择在相对地点买入持有外，我在股市上的投资一直是被收割的命运，就算是赚钱也没有赚到多少。现在看来，当初的所谓投资，都只是浪费事件，瞎折腾。所以这也是不被老婆信任的主要原因吧。

现在本金越来越多，如果还是像以前那样瞎折腾，十年后还是这个样子，老婆大人看不出来的计划的特别之处就在这里。

首先是长线投资的思想

坚持长线投资。以前的瞎折腾都没啥用，耗费了好多的精力，确实是打发时间的好去处。可是人家顶多也就打打麻将，我天天研究K线，日日买进卖出，随着本金增大，亏损的可能性和危害性更大。

关注企业自身发展。最近看了很多价值投资的书，吸收点儿投资的思想，确定了寻找优质企业，并与其一起成长的投资理念。寻找年利润增长率在20%以上的优质企业，学会估值，学会分析企业，寻找这些企业，在合理的价格，买入，持有。就是这样。

投资指数基金

在还没有像老唐那样精于研究企业，对所投资的企业那么熟悉之前，尽量先投资指数。目前A股的估值水平，虽然精力一季度的疯涨，但仍然处于历史地位，继续按计划定期定投即可。

总结

所以，跟老婆讨论一下，明确了我的十年财务自由之路的努力重点，不是增收减支，当然这个很重要，但是我们已经做的够好，或者，不能做的更好了。

重点只剩下一个，努力提升自己，学习分析企业，筛选优质企业，学习如何估值，坚持长线投资。在此之前，主要投资到指数基金即可。

十年财务自由之路——投资实证#0

这是第0次实证——开始(20190328)

上次说过了，无论如何我需要开启自己的十年财务自由之路。其实整个过程没有什么难的，所以副标题用了”一个平静的开始”，我是跟着也谈钱一起来个实证，今天他的初始化放出来了，财务自由之路的初始化。所以，这篇文章就是跟着也谈钱一起踏上财务自由之路的第一步，完成作业。

也谈钱君的作业是这样的：

再给大家总结一下需要做的 todo，算是个作业吧。不把这些问题搞明白，后面的实证跟起来会比较吃力。

明确计划

  • 计算自己的目标被动收入

  • 以 10% 的预期收益率估算所需本金

  • 以 10 年为期，计算目标储蓄额

  • 评估一下这个储蓄额目前是否能达到

增收减支

  • 想办法增加收入
  • 开始记账（事无巨细地记账）
  • 制定预算

认知升级

  • 读书学习

理性思考

  • 没有 Todo，但是你要知道这么一回事

明确计划

自己的目标收入上次已经写过了，目标是700万，以10%的预期收益率估算所需的本金，并且以10年为期，计算目标储蓄额。本以为对我来说会比较轻松，一计算才知道，还是很有挑战的。

按照目标金额700，10%的预期收益率，10年的期限计算，每个月需要固定存入的本金为35,023.83元，目前我的家庭储蓄金额每个月都达标是挺难的，但是按年计算就还算是勉强可以，心中不免有些沮丧，未来十年内能够确保每月都达到目标吗？

折算到年，需要完成年投入42万，这个目标倒是不太难。

1553758362462

好在我并非0起步，目前账户上可供投资的家底儿还有一百二左右，所以起初金额处填入100万后，每个月的目标金额看起来容易多了。

经过调整，每个月需要投入的本金为22,046.3元，一下子负担减轻很多，信心足了，胆子壮了，准备撸袖子搞了。

1553758497833

慢着，这里还有个bug，这里的预期收益率是10%计算的，事实上，能够取得十年平均年化10%的收益率水平，是很有挑战的，我保守点儿，计算下5%的情形下，每个月的本金投入为34,795.21元，哦买噶，收益率对本金投入的影响超级大啊，鸭梨依然在啊。

1553758733193

好吧，看来十年财务自由之路绝非易事，定好目标，更多的时间和精力还是放在工作、学习和控制消费上面吧，最后不死心，再测算下7%的收益率水平，每月的本金投入为29,422.97。

ps：这个计算器确实不错，感谢推荐，链接点击：Ivestment Calculator

小结

  1. 按十年10%年化收益水平，要想达到目标，需要持续每月投入本金为3.5万元；
  2. 考虑到目前有的初始投资本金，可以适当降低每月投入，降低挑战；
  3. 但是想要取得十年的平均年化10%收益率水平绝非易事，需要花费精力和时间，持续地学习提升。
  4. 明确我的每月投入本金目标值3万5，最低值2万9。

增收减支

减支

实话说，平时我的支出并不多，我记账至少有四年时间，所以，对于家庭开支情况还是比较熟悉的。我个人基本上没有什么消费，不抽烟不喝酒，不喜欢应酬热闹，所以这也是为什么我觉得自己适合在国外生活的原因之一。

我们两口子都是这种相对比较简单的人，太太工作特别辛苦特别忙，平日里只是工作和家两点一线，花钱的时间都没有，所以偶尔她想要买些衣服啊化妆品啊，绝对无条件满足。

当然了，我们过的生活绝对不差。老爸老妈牺牲了在老家的自由时光，自打孩子一出生就留在我们身边，默默付出好多年，所以，我们省了保姆的钱，省了请阿姨的钱，每个月给他们的日常花费，他们还会想方设法去很远的批发市场买菜。特别感谢老爸老妈！让我们专心工作，无需顾虑家里和孩子，每天晚上饭桌上总是好多个菜，变着花样的做。

当初我看《不上班也有钱》，很羡慕他们的执行力，但是确实，对于现在的我和我的家庭，我不可能做到那么极致，减支没有什么方法了，但是我会严格控制这一消费水平，不随意提高。

增收

其实，也特别简单，我们两个人都是全职工作，主要的收入来源就是工资。最近几年，我的工作应该有很不错的预期，努力工作，赚取超额提成，争取在未来三年内完成大部分本金的积累是我最主要的目标。这样，后面的压力会小很多。

其他的呢？基本上没有。

确实啊，不写下来不知道，像我们这种典型的双职工家庭，除了工作，没有其他的收入来源，财务上非常脆弱的，一旦我们生病、失业或者意外，就会影响家庭现状，多年来形成的积累难以持续，后面家庭的整体财务状况就会迅速恶化。

当然，无论有没有其他的增收手段，绝大部分人应该都跟我一样，首要的任务是做好本职工作。

其次就是要做好防守，也就是保险的配置，确保小概率事件发生时，不至于一朝回到解放前。

保险

根据也谈钱的介绍和自己的了解，目前我需要配置的是医疗险，支出不大，夫妻两人每年也就一千多块钱，马上去配置就好了，问题不大。

认知升级

除了上面说的，还有啥？就剩下认知升级和一步一步践行了。十年财务自由之路是很枯燥无趣的，十年前我曾经要进行一项长达十年的投资，结果进行了三四年就中断了，现在每每回忆起来，后悔不迭，因为只需要再坚持多两年时间，我的回报就会非常可观，而实际上是，我第一，没有积累足够的本金，第二没有熬到收益实现，死在了黎明前，只剩一地鸡毛。

所以，这一次，是认真的。

为了不中断这个计划，我需要做如下工作：

  1. 每个月进行一次投资操作，按计划将本金投入到拟投资的标的。
  2. 每个月回顾当月预算执行情况，本金投入情况，以及累计本金完成进度。
  3. 每个月完成投资实证，在此博客发布，同时让太太监督。
  4. 持续关注也谈钱的公众号，跟着他一起走。

读书

也谈钱推荐了书单，大部分都已经读过，其中对我印象最深的就是《不上班也有钱》，另外就是《搞定》这本书，大家对他赞誉那么高，为啥我就是读不下去呢？是翻译的问题？感觉好啰嗦。

看了《不上班也有钱》，进而去关注了男女主的博客、FB等，男主博客上的文章，也很有借鉴意义，但好多涉及美国的养老计划，跟我们不太相关。

目前我自己在读的书是唐朝老师的《手把手教你读财报2》，因为我现在持有银行股，要好好研究下银行的报表，认知升级，这才是业余时间的正确打开方式。

无疾到天年——锻炼身体

前段时间读到了杨天南老师的《无疾到天年》，我也开始践行了，坚持跑步和打太极拳，保持健康体魄，活的久，才能实证复利的魔力。

最近我非常推崇的一些网站或者公众号

最近我非常推崇的一些网站或者公众号

也谈钱

也谈钱是我最近特别喜欢跟的公众号，主打理财。博主是一个在德国工作的码农，几年前开始学习理财，并坚持写公众号，进行无私分享。

从这个公众号里，我首先学习了博主根据GTD的使用，优化evernote的目录组织架构，学习GTD技术，优化自己的时间管理；

其次，就坚持学习博主的记账技巧，用我自己的“随手记”APP来记账，并且反复调整摸索，除了预算功能不及他推荐的Wiz，但是免费的，一直坚持着可以用，同步功能优秀，方便导出，就足够了，真的要进行分析，还是导出来在Excel里处理吧。

另外，作者的理念非常的清晰，到底是码农，逻辑清晰，善用工具，执行力强，而且喜欢分享，我第一个花钱的知识星球就奉献给了他。

作者推荐了很多好书，我跟着读了《不上班也有钱》，坚定了自己十年财富自由之路，决定从当下做起，坚持十年，实现自己的财富自由。为此，我也仿照博主的思路，搭建自己的资产配置，定期复盘调整，记录自己的投资之路。由此我也引申出来好多优质资源，比如由于找不到《不上班也有钱》这本书，在喜马拉雅上找到了听的资源，因此找到了终身黑白这位播主，进而呢听到了杨天南，所以又关注了杨天南的财富健康谈。

博主的优质帖子汇总可以点此直达：

2017年文章汇总

2018年文章汇总

杨天南财务健康谈

杨天南是金石致远基金的老大，多年来坚持价值投资，是巴菲特忠实拥趸，曾经参加过BKR的股东大会，还有幸获得提问巴菲特的幸运儿之一。坚持在杂志公布投资实证，定期发表投资文章，取得了非常好的收益。其观念正统，坚持长期投资，价值投资。

作者在工作至于，翻译了《巴菲特致股东的信》、《巴菲特之道》，出版了《一个投资家的二十年》，并且这些书都在其公众号连载。

一个投资家的二十年

巴菲特之道

巴菲特致股东的信还在连载中，没有汇总帖，不过这个价值投资者的圣经，还是多看几遍原文比较好。为此，我也多方搜罗，在百度云上也存了备份，电脑里也下载了中英文版本的原文及翻译，但是还一直没有精力和耐心去看。我的分享链接先放这里：链接: https://pan.baidu.com/s/1XsFCf4Gu_DZla1v5XK-I7Q 提取码: e1m6 ；其实有点儿动手能力的，想顺道加强下英文的，直接官方网站一年年的挨着读也不错，看看老爷子的原文是怎么写的。

据我所知，我所推崇和崇拜的大神级人物唐朝，自己就曾在文章中说过，巴菲特致股东的信自己反反复复读过好多遍，所以才能够随口道来，实在记不清原文的，模糊记得，也很容易通过搜索来提取到原文，可见想要投资成功，还是要勤奋，多研读经典，反复研读，唯有此道，才能持久，方能获得好的投资收益。

唐书房

作者就是大名鼎鼎的唐朝，最开始是在雪球我看过他的文章，总觉得此人很牛，做什么事情都很专业，还能够给出不同于常人的见解，再难再复杂的事情，从他嘴里讲出来就是通俗易懂，印象深刻。后来他开了公众号，我倒是很晚才知道，很早就从雪球上下载帖子学习财报，后来《手把手教你读财报》出版后就买来学习、研读。

唐朝现在是财富自由状态，据他本人讲，对金钱的欲望也不是很强烈，人就或得比较潇洒，这就是我将来的目标，十年后如果被动收入可以覆盖我的正常家庭支出，就表示达到初步的财富自由状态，我也希望那时候可以像唐朝一样随性，陪家里领导四处看风景。

这是后话，这是榜样，路在脚下，慢慢赶上！

公众号文章每一篇都质量上乘，只能坚持学习，学习唐朝的学习精神和方法，形成自己的知识体系，构建适合自己的投资理念，绝对是一位值得尊敬的、乐于分享的牛人。

作者还有《手把手教你读财报2》和《价值投资实战手册》，都非常经典，同样化繁为简，通俗易懂，令人印象深刻，建议人手一套，反复学习。

书房文章精品合集

终身黑白

上面的杨天南和唐书房的文章，我首先是从终身黑白的喜马拉雅号里听到，慢慢才跟着过来的，所以也顺带关注了，感谢作者的引荐，也很佩服作者的坚持。

晓书童

也是推荐好书、读书的好公众号，春节前的送书活动，居然还中了一次福利，获得了免费赠读的《显微镜下的大明》，确实是一本好书，拿到书后两天之内全部读完了，能把历史写的像小说一样兼顾故事性和史学研究分析，绝对值得推荐，也希望有看到这篇文章的，可以找来此书读一读。

少数派

通过Inoreader订阅了少数派，这里接触了很多牛人如何管理自己的知识体系的文章，如何管理自身时间的文章，如何保护隐私，生活中的小窍门等等，内容涉及多样，经常看到好玩有用的文章就及时星标，甚至保存到Evernote里备份。

正式启用Git方式写博客

Git技术是使用Github的基础

–关于Git

Git是使用Github的基础，可惜我好早前曾经试图学习过，但是后来因为种种原因又丢掉了，毕竟自己不是程序员，其实对于版本的要求并不高。

但是最近由于工作中涉及到大量的合同的修改，一个项目的合同版本无数个，而且其中的差异究竟是什么，时间一长自己都搞不清楚了，所以萌生了重新学习Git的想法，于是，这个周末才从廖雪峰老师的网站快速的学习了一遍Git教程，失望地发现Git是没有 办法控制word的版本，那就还是拿来用于更新自己的博客吧。

–接下来要写什么

这段时间以来，一直都是非常的忙，但是写作要继续，只有把读的书，看的文章，利用零散时间学习到的知识写下来，梳理出来，才能很好的吸收掌握，所以我还是会继续把平时工作和生活中总结梳理的技术相关的小技巧啊，有用的小软件啊，在这里做记录。

另外，我还需要记录自己的投资实况。我的十年财务自由之路已经开启，为了督促和监督自己，也需要把相关的进展和执行过程中的一些思考忠实地记录下来，并且可以加以改善、修正。我还需要定期向老婆大人披露执行情况。

–如何坚持

简单的事情做到极致，也能产生很好的效果。

做事情不用贪多，日拱一卒，做好每天就好。

推荐HidelpVPN

转载：
从09年开始hideipvpn.com网站一直提供免费VPN服务，距今已经好几年了活动还在继续着，看一下其免费VPN服务：

免费测试VPN服务

注册即可获得免费试用24小时的美国，英国，荷兰，德国，加拿大，波兰和法国的PPTP，L2TP，SSTP，OpenVPN和SOFTETHER的VPN帐户，主要用于测试HideIpVPN的可用性，也可以用在临时需要VPN时。点击访问此网页填写名、姓和邮箱点击SUBMIT即可收到含有VPN帐号信息的邮件（每个邮箱仅允许申请一次）。另外还可以申请7天的SmartDNS试用。免费试用包括其所有的VPN服务器上。

免费全功能VPN和SmartDNS服务包Ninja Power

如果你有一个博客、网站、论坛，你可以以任何语言写一篇介于150-400字的含有至少一个hideipvpn.com链接的自己原创的推介文章来申请免费全功能VPN和SmartDNS服务Ninja Power。写好之后你可以发邮件给contact [at] hideipvpn.com联系获得免费VPN帐号（点击查看详情）。

官方网址：http://www.hideipvpn.com/

HideIpVPN主要是提供付费VPN服务，目前价格在同类VPN和SmartDNS服务中已经比较便宜了，当然你也可以帮助他们推销VPN服务赚取佣金（有兴趣的可以查看这里和这里）。

本文原始地址：http://igfw.net/archives/6435

战略－－我的第二次分享

各位领导，各位同事，大家早上好。
今天我想给大家端上一碗鸡汤，而且还是经典口味。
我们做投资，很多人都喜欢讲巴菲特，我以前是不喜欢的，最近越来越喜欢巴菲特了，所以今天我也说一下巴菲特。他的确非常牛，11岁买了人生第一支股票，27岁管理资产300万美金，其中有一百万是属于他的，也就是说他在30岁之前就赚到了人生第一个100万。
我曾经试着手绘他的人生财富曲线图，发现其实就是两段，0-30岁差不多就像一条接近于0的水平线，30到现在，简直就是一条竖直向上的直线，就这么成就了他的财富人生。
巴菲特的成功，有很多说法，其中广为人接受的一个说法是啊，他做长线，利用复利的魔力，开出了时间的玫瑰。当然大家知道，财富增长利用复利会像滚雪球一样，快速增加，那么财富减少也是一样的。所以只有复利还不够，还有个充分条件，那就是他做多美国。假设他不是长期持有美国的股票，而是欧洲或者日本的股票，就没有今天这么高的财富积累。

所以说，巴菲特的成功，其实最重要的是他做了一个正确的选择，做多美国，并且长期持有。这是一种战略高度的胜利，任何战术层面的成功都难以与其比拟。

说到战略，前几天我在搜索什么是战略的时候，看到知乎上一个有趣的回答：
某考研党，天天4点起床，背英语单词看政治看专业课上培训班，坚持锻炼，每天花在学习上的时间十几个小时，每天就睡5个小时。
这个叫做战术上的勤奋。
然后你问这个考研党，你为啥要考研呀，考上研之后打算怎么做呀？
然后考研学霸微微一笑，说：我也不知道为啥考研，我妈让我考的，考上研之后我也不知道干嘛，大概考博吧。
这个叫做战略上的懒惰。

前几天得到那个罗胖子不是在分享爆裂这本书吗？其中讲到一点，说是指南针优于地图，我的理解，指南针——战略，地图——战术；指南针优于地图，战略优于战术。

好了，说了这么多，最后还是回到我们自己，我想跟大家说的是，在我们自己人生财富累积的道路上，希望各位不要做只会埋头苦干的人，更要懂得抬头看路，要时刻确保自己走在正确的方向上。

本来今天的分享到这里就可以结束了，不过我觉得这碗鸡汤还有点儿不够浓，再加上一点儿料，放送一个小福利啊：
各位，也许我们生活在一个最好的时代，中国即将进入主升浪，而且看起来还没有什么力量能够阻挡——这是我剽窃我们东总的话啊——那么，我们应该怎么做？

我觉得，坚定信心，做多中国，长期持有！也许，二三十年后的你，就是中国的巴菲特！

谢谢大家！