VBA获取某文件夹下所有文件和子文件目录的文件

【引用位置】 https://blog.csdn.net/pashine/article/details/42100237

'-------------------------------------------

'获取某文件夹下的所有Excel文件

'-------------------------------------------

Sub getExcelFile(sFolderPath As String)

On Error Resume Next

Dim f As String

Dim file() As String

Dim x

k = 1

ReDim file(1)

file(1) = sFolderPath &""

End Sub

'-------------------------------------------

'获取某文件夹下的所有文件和子目录下的文件

'-------------------------------------------

Sub getAllFile(sFolderPath As String)

'Columns(1).Delete

On Error Resume Next

Dim f As String

Dim file() As String

Dim i, k, x

x = 1

i = 1

k = 1

ReDim file(1 To i)

file(1) = sFolderPath &""

'-- 获得所有子目录

Do Until i >k

f = Dir(file(i), vbDirectory)

Do Until f = ""

If InStr(f, ".") = 0 Then

k = k + 1

ReDim Preserve file(1 To k)

file(k) = file(i) &f &""

End If

f = Dir

Loop

i = i + 1

Loop

'-- 获得所有子目录下的所有文件

For i = 1 To k

f = Dir(file(i) &" . ")'通配符 . 表示所有文件，*.xlsx Excel文件

Do Until f = ""

'Range("a" &x) = f

Range("a" &x).Hyperlinks.Add Anchor:=Range("a" &x), Address:=file(i) &f, TextToDisplay:=f

x = x + 1

f = Dir

Loop

Next

End Sub

Function FileCount(cPath As String) as Integer

    cFile=Dir(cPath & "*.*")

    Do While cFile<>""

        FileCount=FileCount+1

        cFile=Dir

    Loop

End Function

这是一段自定义函数，在Excel VBA编辑模式下，主菜单“插入”——“模块”，将代码粘贴到右侧编辑区。如果在工作表状态下使用，在单元格输入：=FileCount("c:\XXX\")就可以得出c:\XXX文件夹下的所有文件个数（不含子文件夹)；如果在代码中使用，则可以：nFileCount=FileCount("c:\XXX\")得到文件个数。注意：cPath参数必须以“\”符号结尾。

1.GetAttr 函数

语法：GetAttr(pathname)

功能：获取一个文件、目录、或文件夹的属性。返回一个 Integer值。

返回值

由 GetAttr 返回的值，是下面这些属性值的总和：

常数 值描述

vbNormal0常规

vbReadOnly1只读

vbHidden2隐藏

vbSystem4 系统文件

vbDirectory16目录或文件夹

vbArchive32存档文件

vbalias64指定的文件名是别名。只在Macintosh中可用。

说明：若要判断是否设置了某个属性，在 GetAttr 函数与想要得知的属性值之间使用 And 运算符与逐位比较。如果所得的结果不为零，则表示设置了这个属性值。

示例：

Debug.Print GetAttr("F:\test.txt") '若为存档文件，在立即窗口可看到值为32

Debug.Print GetAttr("F:\test.txt") '将属性—高级—可存档文件的勾去掉后，值为0

为判断一个文件是否只读，可用下法:

Debug.Print GetAttr("F:\test.txt") And vbReadOnly

若值非零，说明时只读的。

2.复制

'

' （1）.在不需要逐个打开工作簿的情况下,将其有效工作表依次复制到本工作簿的最后.

' 新工作表名为:原工作簿名_原工作表名

'

' Sub 复制工作表()

Dim MyObject As Object

Dim strPath As String, strFileName As String, strMyName As String

Dim shtSheet As Worksheet, strShtName As String

Dim intCount As Integer, intShtCount As Integer, i As Integer

Application.ScreenUpdating = False

strPath = ThisWorkbook.Path

strMyName = ThisWorkbook.Name

intShtCount = ThisWorkbook.Sheets.Count

With Application.FileSearch

.NewSearch

.LookIn = strPath

.SearchSubFolders = False

.Filename = ".xls"

.FileType = msoFileTypeOfficeFiles

If .Execute() >0 Then

intCount = .FoundFiles.Count

For i = 1 To intCount

strFileName = Replace(.FoundFiles(i), strPath &"\", "")

If strFileName <>strMyName Then

Set MyObject = GetObject(strPath &"/" &strFileName)

'下面进行复制工作

For Each shtSheet In MyObject.Worksheets

strShtName = shtSheet.Name

If MyObject.Sheets(strShtName).UsedRange.Count >1 Then

MyObject.Sheets(strShtName).Copy After:=ThisWorkbook.Sheets(intShtCount)

intShtCount = intShtCount + 1

'重新命名

strShtName = Replace(strFileName, ".xls", "_") &strShtName

ThisWorkbook.Sheets(intShtCount).Name = strShtName

ThisWorkbook.Sheets("目录").Cells(i + 1, 1) = strShtName

End If

Next shtSheet

End If

Next i

Else

MsgBox "没有找到符合指定文件，请修改参数后重新搜索！", ,"提示"

End If

End With

ThisWorkbook.Sheets("目录").Select

Application.ScreenUpdating = True

End Sub

'

'（2） 逐个打开同一目录下的所有工作簿,将其有效工作表依次复制到本工作簿的最后.复制完后关闭它.

' 新工作表名为:原工作簿名_原工作表名

'

Sub 复制工作表_2()

Dim MyObject As Object

Dim strPath As String, strFileName As String, strMyName As String

Dim shtSheet As Worksheet, strShtName As String

Dim intCount As Integer, intShtCount As Integer, i As Integer

Application.ScreenUpdating = False

strPath = ThisWorkbook.Path

strMyName = ThisWorkbook.Name

intShtCount = ThisWorkbook.Sheets.Count

With Application.FileSearch

.NewSearch

.LookIn = strPath

.SearchSubFolders = False

.Filename = ".xls"

.FileType = msoFileTypeOfficeFiles

If .Execute() >0 Then

intCount = .FoundFiles.Count

For i = 1 To intCount

strFileName = Replace(.FoundFiles(i), strPath &"\", "")

If strFileName <>strMyName Then

'Workbooks.Open Filename:=strPath &"/" &strFileName

Set MyObject = GetObject(strPath &"/" &strFileName)

'下面进行复制工作

For Each shtSheet In Workbooks(strFileName).Worksheets

strShtName = shtSheet.Name

If Workbooks(strFileName).Sheets(strShtName).UsedRange.Count >1 Then

Workbooks(strFileName).Sheets(strShtName).Copy After:=ThisWorkbook.Sheets(intShtCount)

intShtCount = intShtCount + 1

'重新命名

strShtName = Replace(strFileName, ".xls", "_") &strShtName

ThisWorkbook.Sheets(intShtCount).Name = strShtName

ThisWorkbook.Sheets("目录").Cells(i + 1, 1) = strShtName

End If

Next shtSheet

'Workbooks(strFileName).Close

End If

Next i

Else

MsgBox "没有找到符合指定文件，请修改参数后重新搜索！", ,"提示"

End If

End With

ThisWorkbook.Sheets("目录").Select

Application.ScreenUpdating = True

End Sub

---