您的位置: 首页  >  技术问答  >  从excel表复制范围到名称范围内的新表

从excel表复制范围到名称范围内的新表

分类: 技术问答 • 2022-08-31 10:28:08
问题描述：

我有一个带有受保护工作表的工作簿，它具有预定义的格式和公式，工作表的特定部分有一个下拉列表Actual和Forecast选项。从excel表复制范围到名称范围内的新表

当用户在下拉列表中选择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

答

你正在服用的方法需要许多编码线，将很难如果需要更改维护。

我建议的解决方案使用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。

相关推荐