如何遍历子目录PPT并排除根目录PPT（无需硬编码文件名）

当然可以实现，核心思路是只处理主文件夹下子目录里的PPT文件，直接跳过根目录下的所有文件，根本不用管根目录PPT叫什么名字。

先说说你原来代码的问题：

• 你用了Do While File <> "hardcoded file name"这个循环，但循环内部没有改变File的值，只要当前文件不等于硬编码名称，就会无限执行循环体，直接导致PPT崩溃。
• 你的代码只遍历了主文件夹根目录的文件，完全没处理子文件夹里的内容，这本身就不符合需求。

正确的实现方式 #

可以用两种思路：

思路1：先遍历所有子文件夹，再处理子文件夹内的PPT #

直接获取主文件夹下的所有子文件夹，逐个遍历子文件夹里的PPT文件，完全不碰根目录的文件：

Sub ProcessSubfolderPPTs()
    Dim mainFolder As Folder
    Dim subFolder As Folder
    Dim targetFile As File
    Dim objPresentation As Presentation
    
    ' 替换成你的主文件夹路径
    Set mainFolder = CreateObject("Scripting.FileSystemObject").GetFolder("C:\你的主文件夹路径")
    
    ' 遍历所有子文件夹
    For Each subFolder In mainFolder.SubFolders
        ' 遍历子文件夹里的文件
        For Each targetFile In subFolder.Files
            ' 判断是否是PPT文件（兼容.ppt和.pptx）
            If LCase(Right(targetFile.Name, 4)) = ".ppt" Or LCase(Right(targetFile.Name, 5)) = ".pptx" Then
                Set objPresentation = Presentations.Open(targetFile.Path, msoFalse, msoFalse, msoFalse)
                
                ' 这里放你的PPT操作逻辑
                objPresentation.Slides.Item(1).Copy
                Presentations.Item(1).Slides.Paste
                Presentations.Item(1).Slides.Item(Presentations.Item(1).Slides.Count).Design = _
                    objPresentation.Slides.Item(1).Design
                ' 注意：尽量不用ActivePresentation，用明确的对象引用避免出错
                Presentations.Item(1).Slides(Presentations.Item(1).Slides.Count).Shapes("Rectangle 2").Delete
                
                objPresentation.Close SaveChanges:=msoFalse
            End If
        Next targetFile
    Next subFolder
End Sub

思路2：递归遍历所有文件，跳过根目录文件 #

如果需要处理所有层级的子文件夹但跳过根目录的文件，可以用递归遍历，通过判断文件的父文件夹是否为主文件夹根目录来过滤：

Sub ProcessPPTsExceptRoot()
    Dim mainFolder As Folder
    
    ' 替换成你的主文件夹路径
    Set mainFolder = CreateObject("Scripting.FileSystemObject").GetFolder("C:\你的主文件夹路径")
    
    ' 调用递归函数遍历所有文件
    Call ProcessFilesRecursive(mainFolder)
End Sub

Sub ProcessFilesRecursive(currentFolder As Folder)
    Dim targetFile As File
    Dim subFolder As Folder
    Dim objPresentation As Presentation
    
    ' 遍历当前文件夹的文件
    For Each targetFile In currentFolder.Files
        ' 如果当前文件在主文件夹根目录，直接跳过
        If targetFile.ParentFolder.Path = currentFolder.Path And currentFolder.IsRootFolder Then
            GoTo NextFile
        End If
        
        ' 判断是否是PPT文件
        If LCase(Right(targetFile.Name, 4)) = ".ppt" Or LCase(Right(targetFile.Name, 5)) = ".pptx" Then
            Set objPresentation = Presentations.Open(targetFile.Path, msoFalse, msoFalse, msoFalse)
            
            ' 执行你的操作逻辑
            objPresentation.Slides.Item(1).Copy
            Presentations.Item(1).Slides.Paste
            Presentations.Item(1).Slides.Item(Presentations.Item(1).Slides.Count).Design = _
                objPresentation.Slides.Item(1).Design
            Presentations.Item(1).Slides(Presentations.Item(1).Slides.Count).Shapes("Rectangle 2").Delete
            
            objPresentation.Close SaveChanges:=msoFalse
        End If
NextFile:
    Next targetFile
    
    ' 递归遍历子文件夹
    For Each subFolder In currentFolder.SubFolders
        Call ProcessFilesRecursive(subFolder)
    Next subFolder
End Sub

额外注意点 #

• 避免使用ActivePresentation，尽量用明确的对象引用（比如Presentations.Item(1)），防止切换窗口导致代码出错。
• 处理PPT文件时，要区分.ppt和.pptx格式，用LCase统一转小写判断，避免大小写问题。
• 原来代码里的For i = 1 To 1完全没必要，直接去掉循环，执行一次操作即可。

内容的提问来源于stack exchange，提问作者xiaomao