如何编写宏生成Excel可发布版本并保存至指定SharePoint位置

核心处理逻辑 #

彻底解决原代码的问题：

• 全程以只读模式打开原文件，绝不修改或保存原文件
• 所有处理操作在新创建的副本中完成
• 提前关闭Excel冗余功能（屏幕更新、自动计算等）提升运行速度
• 自动处理SharePoint路径和子目录的创建

实现代码（VBA） #

Sub GeneratePublishedVersions()
    Dim strSourcePath As String
    Dim strSubFolder As String
    Dim strFullSubPath As String
    Dim strFile As String
    Dim wbOriginal As Workbook
    Dim wbPublished As Workbook
    Dim ws As Worksheet
    Dim strFileName As String
    Dim dtSaveDate As Date
    Dim fso As Object
    
    ' --------------------------
    ' 配置参数：按需修改以下内容
    ' --------------------------
    strSourcePath = "https://your-sharepoint-site/sites/TeamName/Documents/TargetFolder/" ' 原文件所在SharePoint路径
    strSubFolder = "Published Versions" ' 保存副本的子目录名称
    dtSaveDate = Date ' 使用当前日期，如需指定日期可改为 DateSerial(2023,6,20)
    
    ' 初始化文件系统对象
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 检查并创建子目录
    strFullSubPath = strSourcePath & strSubFolder & "/"
    If Not fso.FolderExists(strFullSubPath) Then
        fso.CreateFolder strFullSubPath
    End If
    
    ' 优化运行速度的设置
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    
    ' 遍历原路径下的目标Excel文件（这里筛选xlsm格式，按需修改）
    strFile = Dir(strSourcePath & "*.xlsm")
    Do While strFile <> ""
        ' 以只读模式打开原文件，避免修改和锁定
        Set wbOriginal = Workbooks.Open(Filename:=strSourcePath & strFile, ReadOnly:=True)
        
        ' 创建新工作簿作为发布副本
        Set wbPublished = Workbooks.Add
        
        ' 复制原文件中需保留的工作表到副本
        For Each ws In wbOriginal.Worksheets
            ' 跳过需要删除的工作表
            If ws.Name <> "ADMIN" And ws.Name <> "SF_Item_Extract_SF_Item_Status_EC_Report" Then
                ws.Copy After:=wbPublished.Sheets(wbPublished.Sheets.Count)
            End If
        Next ws
        
        ' 删除新工作簿默认的空白工作表
        Application.DisplayAlerts = False
        wbPublished.Sheets(1).Delete
        Application.DisplayAlerts = True
        
        ' 将所有公式转为值，保留格式
        For Each ws In wbPublished.Worksheets
            ws.UsedRange.Value = ws.UsedRange.Value
        Next ws
        
        ' 生成发布版本的文件名
        strFileName = Left(strFile, InStrRev(strFile, ".") - 1) & " - " & Format(dtSaveDate, "dd_mm_yyyy") & ".xlsx"
        
        ' 保存副本到指定子目录（无宏xlsx格式）
        wbPublished.SaveAs Filename:=strFullSubPath & strFileName, FileFormat:=xlOpenXMLWorkbook
        
        ' 关闭文件，不保存原文件
        wbPublished.Close SaveChanges:=False
        wbOriginal.Close SaveChanges:=False
        
        ' 继续下一个文件
        strFile = Dir()
    Loop
    
    ' 恢复Excel默认设置
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
    End With
    
    ' 清理对象
    Set fso = Nothing
    Set wbOriginal = Nothing
    Set wbPublished = Nothing
    
    MsgBox "发布版本生成完成！", vbInformation
End Sub

关键优化点说明 #

• 原文件保护：通过ReadOnly:=True打开原文件，全程不保存原文件，确保原工作簿完整保留
• 路径处理：使用FileSystemObject自动创建子目录，无需手动维护路径
• 速度提升：关闭屏幕更新、自动计算和事件触发，减少冗余操作
• 格式合规：强制保存为xlOpenXMLWorkbook（xlsx）格式，确保无宏
• 精准筛选：明确跳过指定名称的工作表，避免误删

使用注意事项 #

1. 替换代码中的strSourcePath为你的SharePoint文件夹实际路径
2. 确认strSubFolder名称符合你的需求，代码会自动创建该子目录
3. 如需筛选特定命名规范的文件，可修改Dir函数的通配符（比如"*Training Matrix*.xlsm"）
4. 运行宏前确保Excel已启用宏功能，且有权限访问目标SharePoint库

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