我有一张带有受保护工作表的工作簿，该工作簿具有预定义的格式和公式，并且工作表的特定部分包含一个带有Actual和Forecast选项的下拉列表。
当用户在下拉列表中选择Actual时，所有相应的单元格公式都会转换为值（使用paste special），并且无法调用。但是，一旦用户再次在工作表上选择Forecast，我需要还原并调用所有公式。此下拉值是特定于列的。
我使用下面的代码“粘贴特殊值作为值”，并在模板表中使用公式来复制公式。
我需要帮助的区域是如何将它们粘贴到目标单元格中
If ActiveCell.Value = "Actual" Then
If Sheets("Template").Range("B1").Value <> 1 Then
Answer = MsgBox("Once you change this drop down to 'Actual' the formulas below in the monthly breakdown section will be changed to constant values; and will not be revereted back", vbYesNo)
If Answer = vbNo Then
Application.Undo
Application.StatusBar = ""
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
End If
End If
Sheets("Template").Range("B1").Value = 1
arrng = Cellinrng(ActiveCell)
If InStr(1, arrng(0), "PrjRel") = 0 Then
Application.DisplayAlerts = False
Exit Sub
Else
If ActiveCell.Row = Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(-4, 0).Row Then
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim activcell
Set activcell = ActiveCell
Call sbUnProtectSheet(ActiveSheet.Name)
Range(Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(-1, ActiveCell.Column - 2).Address & ":" & Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(1, ActiveCell.Column - 2).Address).Copy
Range(Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(-1, ActiveCell.Column - 2).Address & ":" & Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(1, ActiveCell.Column - 2).Address).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Range(Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(5, ActiveCell.Column - 2).Address & ":" & Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(5, ActiveCell.Column - 2).Address).Copy
Range(Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(5, ActiveCell.Column - 2).Address & ":" & Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(5, ActiveCell.Column - 2).Address).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Range(Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(8, ActiveCell.Column - 2).Address & ":" & Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(8, ActiveCell.Column - 2).Address).Copy
Range(Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(8, ActiveCell.Column - 2).Address & ":" & Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(8, ActiveCell.Column - 2).Address).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Range(Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(10, ActiveCell.Column - 2).Address & ":" & Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(10, ActiveCell.Column - 2).Address).Copy
Range(Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(10, ActiveCell.Column - 2).Address & ":" & Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6))(10, ActiveCell.Column - 2).Address).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6)).Select
Range("Rev_Rec" & Right(arrng(0), Len(arrng(0)) - 6)).Formula = "=SUMIF(OFFSET($C" & (ActiveCell.Row - 5) & ",0,0,ROW($C" & (ActiveCell.Row - 5) & ")-ROW($C" & (ActiveCell.Row - 5) & ")+1,COLUMN()-COLUMN($C" & (ActiveCell.Row - 5) & ")),""Actual"",Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6) & ")"
Range("Rev_Rec" & Right(arrng(0), Len(arrng(0)) - 6)).Copy
Range("Rev_Rec" & Right(arrng(0), Len(arrng(0)) - 6)).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6)).Select
Range("Hours_Actual" & Right(arrng(0), Len(arrng(0)) - 6)).Formula = "=SUMIF(OFFSET($D" & (ActiveCell.Row - 5) & ",0,0,ROW($D" & (ActiveCell.Row - 5) & ")-ROW($D" & (ActiveCell.Row - 5) & ")+1,COLUMN()-COLUMN($D" & (ActiveCell.Row - 5) & ")),""Actual"",sumRange)"
Range("Hours_Actual" & Right(arrng(0), Len(arrng(0)) - 6)).Copy
Range("Hours_Actual" & Right(arrng(0), Len(arrng(0)) - 6)).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Range("Rev_Line" & Right(arrng(0), Len(arrng(0)) - 6)).Select
Range("Netwrk_Days_Actual" & Right(arrng(0), Len(arrng(0)) - 6)).Formula = "=SUMIF(OFFSET($D" & (ActiveCell.Row - 5) & ",0,0,ROW($D" & (ActiveCell.Row - 5) & ")-ROW($D" & (ActiveCell.Row - 5) & ")+1,COLUMN()-COLUMN($D" & (ActiveCell.Row - 5) & ")),""Actual"",sumRange)"
Range("Netwrk_Days_Actual" & Right(arrng(0), Len(arrng(0)) - 6)).Copy
Range("Netwrk_Days_Actual" & Right(arrng(0), Len(arrng(0)) - 6)).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
End If
End If
答案 0 :(得分：0)
您正在采用的方法需要许多编码行，如果需要更改，将难以维护。
我提议的解决方案使用Worksheet_Change事件触发程序将公式更改为值并重新公式，它还使用Range.SpecialCells Method (Excel)来识别需要的单元格处理。如果发生变化，这将简化程序的维护。
此解决方案假定：
DATA和DataValidation位于D4（更改为
需要）Template（根据需要更改）DATA是其复制品
工作表Template和两个工作表都受到保护（更改为
需要）<强>解决方案：
将此代码复制到工作表DATA
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const kCll As String = "$D$4"
With Target.Cells(1)
If .Address = kCll Then Call WshAct_Actual_Or_Forecast(CStr(.Value2), .Worksheet)
End With
End Sub
将此代码复制到标准VBA模块
中Option Explicit
Public Sub WshAct_Actual_Or_Forecast(sCllVal As String, wshTrg As Worksheet)
Dim rTrg As Range
Rem Application Settings Off
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.DisplayAlerts = False
.ScreenUpdating = False
End With
Rem Set Target Range to Process
Set rTrg = wshTrg.Range("E7:AB16") 'change as required
' In Procedures "Wsh_SetFormulas_ToValues" and "Wsh_SetFormulas_FromTemplate"
' the Target Range to Process is optional.
' Therefore if the Target Range is not provided the procedures
' will process the UsedRange of the Target Worksheet.
Rem Validate Cell Value
Select Case sCllVal
Case "Actual"
Rem Add here any required validation!
Rem Message to User
If MsgBox(Title:="Data Type [" & sCllVal & "]", _
Prompt:="Formulas in the monthly breakdown will be changed to constant values" & _
vbLf & vbLf & vbTab & "Do you want to continue?", _
Buttons:=vbSystemModal + vbMsgBoxSetForeground + vbQuestion + vbOKCancel) = vbCancel Then GoTo ExitTkn
If rTrg Is Nothing Then
Rem To change all formulas in target worksheet
Call Wsh_SetFormulas_ToValues(wshTrg)
Else
Rem To change formulas only in Target Range
Call Wsh_SetFormulas_ToValues(wshTrg, rTrg)
End If
Case "Forecast"
Rem Add here any required validation!
If rTrg Is Nothing Then
Rem To restate all formulas in target worksheet
Call Wsh_SetFormulas_FromTemplate(wshTrg)
Else
Rem To restate formulas only in Target Range
Call Wsh_SetFormulas_FromTemplate(wshTrg, rTrg)
End If
End Select
ExitTkn:
Rem Application Settings ON
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Sub Wsh_SetFormulas_ToValues(wshTrg As Worksheet, Optional ByVal rTrg As Range)
Dim rArea As Range
Call Wsh_Protection_OFF(wshTrg) 'change as required
Rem Validate\Set Target Range
If rTrg Is Nothing Then Set rTrg = wshTrg.UsedRange
Rem Set Target Range to Values
For Each rArea In rTrg.Areas
With rArea
.Value = .Value2
End With: Next
Call Wsh_Protection_ON(wshTrg) 'change as required
End Sub
Sub Wsh_SetFormulas_FromTemplate(wshTrg As Worksheet, Optional ByVal rTrg As Range)
Const kWshSrc As String = "Template"
Dim wshSrc As Worksheet
Dim rSrc As Range, rSrcArea As Range, rTrgArea As Range
Rem Set Source Worksheet - Template
On Error Resume Next
Set wshSrc = ThisWorkbook.Worksheets(kWshSrc)
On Error GoTo 0
If wshSrc Is Nothing Then
MsgBox "Template Worksheet is missing!", _
vbSystemModal + vbCritical + vbMsgBoxSetForeground
Exit Sub
End If
Call Wsh_Protection_OFF(wshSrc)
Call Wsh_Protection_OFF(wshTrg)
Rem Validate\Set Target Range
If rTrg Is Nothing Then Set rTrg = wshTrg.UsedRange
Rem Set Source Formula Range
Set rSrc = wshSrc.Range(rTrg.Address).SpecialCells(xlCellTypeFormulas, _
xlErrors + xlLogical + xlNumbers + xlTextValues)
Rem Set Target Range Formulas
For Each rSrcArea In rSrc.Areas
Set rTrgArea = wshTrg.Range(rSrcArea.Address)
rSrcArea.Copy
rTrgArea.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats
Application.CutCopyMode = False
Next
Call Wsh_Protection_ON(wshTrg)
Call Wsh_Protection_ON(wshTrg)
End Sub
建议阅读以下页面以深入了解所使用的资源：
For Each...Next Statement，Range Object (Excel)，Select Case Statement，