從excel表複製範圍到名稱範圍內的新表

Question

我有一個帶有受保護工作表的工作簿，它具有預定義的格式和公式，工作表的特定部分有一個下拉列表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 

Answer 1

你正在服用的方法需要許多編碼線，將很難如果需要更改維護。

我建議的解決方案使用Worksheet_Change事件來觸發程序將公式更改爲值並重新公式化，它還使用Range.SpecialCells Method (Excel)來標識需要處理的單元格。這將減輕您的程序在發生變化時的維護。

該解決方案假定：

• 用戶將變更爲實際或預測中的工作表被命名爲 DATA和DataValidation位於D4（需要作爲 變化）
• 與工作表標準公式命名爲 Template（根據需要更改）
• 工作表DATA是 副本的工作表Template和兩個工作表被保護的（如 所需改變）

解決方案：

複製這個代碼在工作表中的VBA模塊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，

Worksheet Object Events，With Statement。