受保护启用宏Excel工作簿无法保存带数据的无宏副本求助

问题背景 #

这是一个仅开放用户输入字段的受保护工作簿，宏流程除归档功能外均正常：

• 用户每周在工作表录入数据，可正常保存启用宏的工作簿；
• 管理员（通过Environ$("username")验证）每周一点击按钮，需清除所有条目并生成一个无VBA、无按钮的普通Excel归档副本；
• 目前所有步骤都能执行，但生成的归档副本没有任何数据，添加ActiveWorkbook.Save命令后问题依旧。

原关联Button 2的ResetTracker宏及相关代码 #

Sub ResetTracker()

'First save this workbook
ActiveWorkbook.Save

MsgBox "Please select the location for this file"
Dim strPath As String

Sheets("Setup").Range("A2") = ""

strPath = ""

strPath = GetFolderPath

If strPath <> "" Then
    Debug.Print strPath
   
      
    Sheets("Setup").Range("A2") = strPath

    If MsgBox("Are you sure you want to reset and archive the tracker?", vbYesNo + vbQuestion) = vbYes Then
        Range("F8:J10,F13:J15,F18:J20,F23:J25,F28:J30").Select
        Range("F28").Activate
        ActiveWindow.SmallScroll Down:=0
        Selection.ClearContents
        Range("F8").Select
    End If

    Dim NewWb As Workbook
    Set NewWb = Workbooks.Add
    ThisWorkbook.Sheets("Weekly Requisition Tracker").Copy Before:=NewWb.Sheets(1)

    Dim btn As Shape
    For Each btn In NewWb.Sheets("Weekly Requisition Tracker").Shapes
        btn.Delete
    Next btn


Application.DisplayAlerts = False 'suppress warning message
    Dim i As Long
    With NewWb
        For i = .Sheets.Count To 2 Step -1
            .Sheets(i).Delete
        Next i
        .SaveAs Filename:=strPath & "\Weekly Requisition Tracker_" & DateString & ".xlsx", _
            FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        .Close False
    End With
Application.DisplayAlerts = True


    MsgBox "Your tracker was successfully saved to: " & strPath
End If


End Sub

Public Function GetFolderPath(Optional strTitle As String)
 Dim strFile As String
 Dim strPath As String
    
    strFile = pickFolderPath(, strTitle)
    If strFile <> "" Then
        'strPath = PathOnly(strFile)
        GetFolderPath = strFile
    End If


End Function

Public Function pickFolderPath(Optional ByVal initPath As String = "", Optional strTitle As String) As String
'Allows user to select a single file from a dialog box (no file type filter)
 Dim FD As Object
 Set FD = Application.FileDialog(4) 'msoFileDialogFolderPicker=4
 FD.InitialFileName = initPath
 
 If strTitle <> "" Then
    FD.Title = strTitle
 End If
 
 FD.AllowMultiSelect = False
 Dim vrtSelectedItem As String
 If FD.Show = -1 Then pickFolderPath = FD.SelectedItems(1)
 Set FD = Nothing
End Function

Public Function DateString() As String
Dim YY As String
Dim MM As String
Dim DD As String
Dim HH As String
Dim nn As String

YY = Year(Now())
MM = Month(Now())
DD = Format(Day(Now()), "00")
HH = Format(Hour(Now()), "00")
nn = Format(Minute(Now()), "00")


DateString = YY & MM & DD & "_" & HH & nn

End Function

问题根源 #

代码执行顺序逻辑错误：先清除了原工作簿的数据，再复制工作表到新工作簿，导致新工作簿里的内容是已清空后的状态，自然没有数据。同时，原代码直接使用Range未指定工作表，存在激活其他工作表时的潜在错误；若原工作表处于保护状态，ClearContents也可能无法正常执行。

修正后的代码 #

调整执行顺序，先复制归档工作表，再清除原工作簿数据；同时优化代码，避免使用Select/Activate操作，指定明确的工作表对象：

Sub ResetTracker()
    Dim strPath As String
    Dim wsTracker As Worksheet
    Dim NewWb As Workbook
    Dim btn As Shape
    Dim i As Long
    
    ' 保存原工作簿
    ActiveWorkbook.Save
    
    Set wsTracker = ThisWorkbook.Sheets("Weekly Requisition Tracker")
    
    MsgBox "请选择归档文件保存位置"
    strPath = GetFolderPath
    
    If strPath <> "" Then
        Debug.Print strPath
        ThisWorkbook.Sheets("Setup").Range("A2") = strPath
        
        ' 先复制工作表到新工作簿（归档），再清除原数据
        If MsgBox("确定要重置并归档追踪表吗？", vbYesNo + vbQuestion) = vbYes Then
            ' 创建新工作簿并复制追踪表
            Set NewWb = Workbooks.Add
            wsTracker.Copy Before:=NewWb.Sheets(1)
            
            ' 删除新工作簿里的默认工作表
            Application.DisplayAlerts = False
            For i = NewWb.Sheets.Count To 2 Step -1
                NewWb.Sheets(i).Delete
            Next i
            Application.DisplayAlerts = True
            
            ' 删除新工作表中的按钮
            For Each btn In NewWb.Sheets(1).Shapes
                btn.Delete
            Next btn
            
            ' 保存归档文件
            NewWb.SaveAs Filename:=strPath & "\Weekly Requisition Tracker_" & DateString & ".xlsx", _
                FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            NewWb.Close False
            
            ' 清除原工作簿的数据（如果工作表受保护，需先解除保护）
            ' 若工作表有保护密码，替换为实际密码，如 wsTracker.Unprotect Password:="123"
            wsTracker.Unprotect
            wsTracker.Range("F8:J10,F13:J15,F18:J20,F23:J25,F28:J30").ClearContents
            wsTracker.Protect ' 恢复保护，若不需要可删除此行
            
            MsgBox "追踪表已成功归档至：" & strPath
        End If
    End If
End Sub

额外注意事项 #

1. 如果原工作表有保护密码，需在wsTracker.Unprotect后添加对应密码参数；
2. 确保Environ$("username")的管理员验证逻辑已正确添加到宏中（原代码未体现，需确认是否遗漏）；
3. 移除Select/Activate操作可提升宏的稳定性，避免因工作表切换导致的错误。

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