Sub 批量修改母版()
    Application.ScreenUpdating = False
    newMasterName = "创意素材铺YYDS"  ' 指定的新母版名称
    Set fso = CreateObject("scripting.filesystemobject")
    Set ff = fso.GetFolder("C:\Users\Administrator\Desktop\test") 'ThisWorkbook.Path是当前代码文件所在路径，路径名可以根据需求修改
    ActiveSheet.UsedRange.ClearContents
    
    a = 1
    For Each f In ff.Files
        If f Like ".ppt" Or f Like ".pptx" Then
            ' MsgBox "发现" & f.Name
            Set Myppt = CreateObject("PowerPoint.Application")
            Myppt.Visible = True
            
            Set newppt = Myppt.Presentations.Open(Filename:=f)
            
    
            Dim master As Object
            For Each master In newppt.Designs
                master.Name = newMasterName  ' 重命名母版
            Next master
            
            newppt.Save
            newppt.Close
            
            Set newppt = Nothing
            Set Myppt = Nothing
            
            Cells(a, 1) = f.Name '相对路径名
            Cells(a, 2) = f '全路径名
            a = a + 1
        End If
        
    Next f

    Application.ScreenUpdating = True
    
End Sub