我有一个VBA脚本，旨在从一个页面的单元格范围复制数据，并将其粘贴到其他页面的另一个单元格范围，粘贴到的范围会根据星期几而变化。该脚本执行时没有错误，但数据却未能被复制。

我对VBA几乎只是初学者，找不到代码中的问题。

我希望能知道我哪里出错了。

以下是我正在使用的代码：

Sub Test()

' Copy information Visual Basic control _
  Script written on 05/07/2026 by me _
  Copies data to appropriate locations for Thaw and Prep worksheets

    Dim wsMenu As Worksheet
    Dim wsThaw As Worksheet
    Dim wsPrep As Worksheet
    Dim wsHourly As Worksheet
    Dim destRange As String
    Dim dayName As String

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False

    ' Set worksheet references
    Set selectedSheet = ActiveSheet
    Set wsMenu = ThisWorkbook.Worksheets("Menu")
    Set wsThaw = ThisWorkbook.Worksheets("Daily thaw")
    Set wsPrep = ThisWorkbook.Worksheets("Daily prep")
    Set wsHours = ThisWorkbook.Worksheets("Half hourly sales")

    dayName = Format(Date, "dddd")

    ' Determine destination by day of week
    Select Case dayName

        Case "Friday"
            destRange = "C5:C15"

        Case "Saturday"
            destRange = "C20:C30"

        Case "Sunday"
            destRange = "C35:C45"

        Case "Monday"
            destRange = "C50:C60"

        Case "Tuesday"
            destRange = "C65:C75"

        Case "Wednesday"
            destRange = "C80:C90"

        Case "Thursday"
            destRange = "C95:C105"

        Case Else
            GoTo CleanExit

    End Select

    ' Copy data from Menu to Daily Thaw
    Sheets("Daily thaw").Unprotect
    wsThaw.Range(destRange).Value = wsMenu.Range("E5:E15").Value
    Sheets("Daily thaw").Protect

    ' Copy data from Menu to Daily Prep
    Sheets("Daily prep").Unprotect
    wsPrep.Range(destRange).Value = wsMenu.Range("G5:G15").Value
    Sheets("Daily prep").Protect

    ' Clear source ranges
    Sheets("Menu").Unprotect
    wsMenu.Range("E5:E15, G5:G15").ClearContents
    Sheets("Menu").Protect

CleanExit:

    wsMenu.Select

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True


End Sub

解决方案

复制与清除数据

• 一旦从源工作表（“Menu”）中清除了数据，如果你不小心再次运行代码，这些现在为空的单元格将覆盖先前已复制到目标的数据。
• 为防止这种情况，你可以使用以下函数，...

Function IsRangeEmpty(ByVal rg As Range) As Boolean
    Dim cell As Range
    For Each cell In rg.Cells
        If Not IsEmpty(cell) Then Exit Function
    Next cell
    IsRangeEmpty = True
End Function

...在执行之前先检查源范围是否非空，例如：

Dim mrg As Range

Set mrg = wsMenu.Range("E5:E15")
If Not IsRangeEmpty(mrg) Then
    With wsThaw
        .Unprotect
        .Range(destRange).Value = mrg.Value
        .Protect
    End With
End If

Set mrg = wsMenu.Range("G5:G15")
If Not IsRangeEmpty(mrg) Then
    With wsPrep
        .Unprotect
        .Range(destRange).Value = mrg.Value
        .Protect
    End With
End If

• 这里有一种稍有不同的方法。遇到空的源范围时，它会退出。

Sub MoveToDaily()

    ' Define constants.
    Const S_SHEET_NAME As String = "Menu"
    ' The following two need to be in sync.
    Dim S_RANGE_ADDRESSES() As Variant: S_RANGE_ADDRESSES = VBA.Array( _
        "E5:E15", "G5:G15")
    Dim D_SHEET_NAMES() As Variant: D_SHEET_NAMES = VBA.Array( _
        "Daily Thaw", "Daily Prep")
    Const D_FIRST_RANGE_ADDRESS As String = "C5:C15"
    Const D_ROWS_COUNT As Long = 15
    Dim D_FIRST_DAY_OF_WEEK As VBA.VbDayOfWeek: D_FIRST_DAY_OF_WEEK = vbFriday

    ' Determine the date.
    Dim MoveDate As Date: MoveDate = Date ' today='Date'; yesterday='Date - 1'

    ' Determine the destination row offset.
    Dim dRowOffset As Long: dRowOffset = _
        (VBA.Weekday(MoveDate, D_FIRST_DAY_OF_WEEK) - 1) * D_ROWS_COUNT

    ' Reference the workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code

    ' Reference the source sheet.
    Dim sws As Worksheet: Set sws = wb.Sheets(S_SHEET_NAME)

    Application.ScreenUpdating = False

    sws.Unprotect

    Dim srg As Range, drg As Range, i As Long, WasEmptyRangeFound As Boolean

    ' Loop through the destination sheets (and the source range addresses)...
    For i = 0 To UBound(D_SHEET_NAMES)
        ' Reference (and check) the source range.
        Set srg = sws.Range(S_RANGE_ADDRESSES(i))
        If IsRangeEmpty(srg) Then
            MsgBox "The source range ""'" & sws.Name & "'!" _
                & srg.Address(0, 0) & """ is empty!", vbExclamation
            WasEmptyRangeFound = True
            Exit For
        End If
        With wb.Sheets(D_SHEET_NAMES(i))
            .Unprotect
            ' Reference the destination range.
            Set drg = .Range(D_FIRST_RANGE_ADDRESS).Offset(dRowOffset)
            ' Copy values only.
            drg.Value = srg.Value
            .Protect
        End With
        srg.ClearContents
    Next i

    sws.Protect

    wb.Activate ' before selecting a sheet, make sure its workbook is active
    sws.Select

    Application.ScreenUpdating = True

    ' Inform the user.
    If WasEmptyRangeFound Then Exit Sub
    MsgBox "Data moved to daily sheets.", vbInformation

End Sub