VBA实用案例-遍历 / 开普饭

遍历是我们常用的一种方式，下面介绍5种场景的文件遍历，代码案例在文末，大家自行下载，自己按照各自需求修改：

【一、遍历当前文件夹下一层子文件夹】

Sub 按钮1_Click()

Application.ScreenUpdating = False

Set fso = CreateObject('scripting.filesystemobject')

Set ff = fso.getfolder(ThisWorkbook.Path) 'ThisWorkbook.Path是当前代码文件所在路径，路径名可以根据需求修改

ActiveSheet.UsedRange.ClearContents

a = 1

For Each fd In ff.subfolders

Cells(a, 1) = fd.Name '子文件夹名,相对于当前文件夹的名字

Cells(a, 2) = fd '子文件夹全路径

a = a + 1

Next fd

Application.ScreenUpdating = True

End Sub

【二、遍历当前文件夹文件名】

Sub 按钮1_Click()

Application.ScreenUpdating = False

Set fso = CreateObject('scripting.filesystemobject')

Set ff = fso.getfolder(ThisWorkbook.Path) 'ThisWorkbook.Path是当前代码文件所在路径，路径名可以根据需求修改

ActiveSheet.UsedRange.ClearContents

a = 1

For Each f In ff.Files

Rem 如果不需要提取本代码文件名，可以增加if语句 if f.name<> thisworkbook.name then.....

Rem 如果值需要提取某类文件，需要对f.name的扩展名进行判断

Rem 个人感觉split取扩展名：split（f.name,'.')(ubound（split（f.name,'.')）)，然后再判断，避免文件名还有其他“.”

Cells(a, 1) = f.Name '相对路径名

Cells(a, 2) = f '全路径名

a = a + 1

Next f

Application.ScreenUpdating = True

End Sub

【三、遍历当前文件夹所有子文件夹】

Sub 按钮1_Click()

Application.ScreenUpdating = False

ActiveSheet.UsedRange.ClearContents

Cells(1, 1) = '文件夹名'

Getfd (ThisWorkbook.Path) 'ThisWorkbook.Path是当前代码文件所在路径，路径名可以根据需求修改

Application.ScreenUpdating = True

End Sub

Sub Getfd(ByVal pth)

Set Fso = CreateObject('scripting.filesystemobject')

Set ff = Fso.getfolder(pth)

Cells(Rows.Count, 1).End(3).Offset(1) = pth

For Each fd In ff.subfolders

Getfd (fd)

Next fd

End Sub

【四、遍历当前文件夹及所有子文件夹下的文件】

Sub 按钮1_Click()

Application.ScreenUpdating = False

ActiveSheet.UsedRange.ClearContents

Cells(1, 1) = '相对路径文件名'

Cells(1, 2) = '绝对路径文件名'

Getfd (ThisWorkbook.Path) 'ThisWorkbook.Path是当前代码文件所在路径，路径名可以根据需求修改

Application.ScreenUpdating = True

End Sub

Sub Getfd(ByVal pth)

Set Fso = CreateObject('scripting.filesystemobject')

Set ff = Fso.getfolder(pth)

For Each f In ff.Files

Rem 具体提取哪类文件，还是需要根据文件扩展名进行处理

Cells(Rows.Count, 1).End(3).Offset(1) = f.Name

Cells(Rows.Count, 2).End(3).Offset(1) = f

Next f

For Each fd In ff.subfolders

Getfd (fd)

Next fd

End Sub

【五、汇总当前文件夹及子文件夹下所有excel文件内容】

Public d

Sub 按钮1_Click()

Application.ScreenUpdating = False

ActiveSheet.UsedRange.ClearContents

Cells(1, 1) = '编号'

Cells(1, 2) = '数量'

Set d = CreateObject('scripting.dictionary')

Getfd (ThisWorkbook.Path) 'ThisWorkbook.Path是当前代码文件所在路径，路径名可以根据需求修改

Application.ScreenUpdating = True

If d.Count > 0 Then

ThisWorkbook.Sheets(1).[a2].Resize(d.Count) = WorksheetFunction.Transpose(d.keys)

ThisWorkbook.Sheets(1).[b2].Resize(d.Count) = WorksheetFunction.Transpose(d.items)

End If

End Sub

Sub Getfd(ByVal pth)

Set Fso = CreateObject('scripting.filesystemobject')

Set ff = Fso.getfolder(pth)

For Each f In ff.Files

Rem 具体提取哪类文件，还是需要根据文件扩展名进行处理

If InStr(Split(f.Name, '.')(UBound(Split(f.Name, '.'))), 'xl') > 0 Then

If f.Name <> ThisWorkbook.Name Then

Set wb = Workbooks.Open(f)

For Each sht In wb.Sheets

If WorksheetFunction.CountA(sht.UsedRange) > 1 Then

arr = sht.UsedRange

For j = 2 To UBound(arr)

d(arr(j, 1)) = d(arr(j, 1)) + arr(j, 2)

Next j

End If

Next sht

wb.Close False

End If

Next f

For Each fd In ff.subfolders

Getfd (fd)

Next fd

End Sub

点个在看你最好看

VBA实用案例-遍历

相关推荐