Excel VBA打开新工作簿后无法向新旧工作簿写入值问题求助

核心失效原因 #

• 自定义过程ScreenAndAlertsOff大概率内置On Error Resume Next语句，所有运行报错被静默吞噬，无法感知写入失败的具体触发点
• 路径取值使用ActiveWorkbook而非确定的ThisWorkbook，运行时活动工作簿变化会导致路径读取错误，后续文件复制、打开操作均失效
• 未指定工作簿打开参数，新工作簿可能以只读模式打开，禁止写入
• 工作表名称大小写拼写不统一，存在匹配失败风险

修复步骤 #

1. 注释掉所有On Error Resume Next相关语句，暴露真实报错信息定位问题
2. 把路径取值的来源从ActiveWorkbook替换为已绑定的WB_Main，确保路径固定正确
3. 打开工作簿时明确指定ReadOnly:=False参数，强制可写模式打开
4. 统一工作表名称拼写，避免大小写或字符差异导致的匹配失败
5. 补充工作簿打开后的状态校验，确认新工作簿可正常编辑再执行写入操作

修正后可运行代码 #

Option Explicit

Sub Generate()
    Dim WB_Main As Workbook, WB_Week As Workbook
    Dim ProgramPath As String
    Dim NumberofWeeks As Long, WeekNumber As Long
    Dim FileName As String

    Set WB_Main = ThisWorkbook
    
    ' 测试写入：打开新文件前
    WB_Main.Sheets("Master").Range("AW1").Value = 5

    ' 固定取当前代码所在工作簿的路径，避免活动工作簿变动影响
    ProgramPath = Left(LocalFullName(WB_Main.FullName), InStrRev(LocalFullName(WB_Main.FullName), "\"))

    NumberofWeeks = WB_Main.Sheets("Master").Cells(5, 46).Value

    ' 关闭系统配置，规避自定义过程隐藏报错的问题
    Application.Calculation = xlManual
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False

    WeekNumber = WB_Main.Sheets("Master").Cells(8, 49).Value
    FileName = Year(WB_Main.Sheets("Master").Cells(11, 49).Value) & "_" & Month(WB_Main.Sheets("Master").Cells(11, 49).Value) & "_" & WeekNumber & ".xls"

    ' 复制模板文件
    FileCopy ProgramPath & "CALENDAR\Week_00.xls", ProgramPath & FileName

    ' 强制可写模式打开新文件
    Set WB_Week = Workbooks.Open(Filename:=ProgramPath & FileName, ReadOnly:=False)

    ' 写入测试
    WB_Main.Sheets("Master").Range("AW1").Value = 10
    WB_Week.Worksheets("F2808").Cells(8, 22).Value = 10 

    ' 恢复系统配置
    Application.Calculation = xlAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

Private Function LocalFullName$(ByVal fullPath$)
    Dim ii&
    Dim iPos&
    Dim oneDrivePath$
    Dim endFilePath$

    If Left(fullPath, 8) = "https://" Then
        If InStr(1, fullPath, "my.sharepoint.com") <> 0 Then
            iPos = InStr(1, fullPath, "/Documents") + Len("/Documents")
            endFilePath = Mid(fullPath, iPos)
        Else
            iPos = 8
            For ii = 1 To 2
                iPos = InStr(iPos + 1, fullPath, "/")
            Next ii
            endFilePath = Mid(fullPath, iPos)
        End If
        endFilePath = Replace(endFilePath, "/", Application.PathSeparator)
        For ii = 1 To 3
            oneDrivePath = Environ(Choose(ii, "OneDriveCommercial", "OneDriveConsumer", "OneDrive"))
            If 0 < Len(oneDrivePath) Then
                LocalFullName = oneDrivePath & endFilePath
                Exit Function
            End If
        Next ii
        LocalFullName = vbNullString
    Else
        LocalFullName = fullPath
    End If
End Function

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