Vba 将范围从excel工作表复制到具有名称范围的新工作表_Vba_Excel

Vba 将范围从excel工作表复制到具有名称范围的新工作表

vba excel

Vba 将范围从excel工作表复制到具有名称范围的新工作表,vba,excel,Vba,Excel,我有一个带有受保护工作表的工作簿，该工作表具有预定义的格式和公式，工作表的特定部分有一个下拉列表，其中包含实际和预测选项当用户在下拉列表中选择Actual时，所有相应单元格的公式都会转换为值（使用paste special），并且无法调用。但是，一旦用户在工作表上再次选择了Forecast，我需要将其还原并调用所有公式。此下拉值是特定于列的我使用下面的代码“粘贴特殊值”，并有一个模板表中的公式复制回公式我需要帮助的地方是如何将它们粘贴到目标单元格中 If ActiveCell.Value

我有一个带有受保护工作表的工作簿，该工作表具有预定义的格式和公式，工作表的特定部分有一个下拉列表，其中包含

实际

和

预测

选项

当用户在下拉列表中选择

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

如果ActiveCell.Value=“实际”则
如果图纸（“模板”）。范围（“B1”）。值为1，则
Answer=MsgBox（“一旦您将此下拉列表更改为“实际值”，每月细分部分中的以下公式将更改为常量；并且不会反向反射”，vbYesNo）
如果答案=vbNo，则
应用程序。撤消
Application.StatusBar=“”
Application.EnableEvents=True
Application.ScreenUpdating=True
Application.Calculation=xlCalculationAutomatic
出口接头
如果结束
如果结束
图纸（“模板”）。范围（“B1”）。值=1
arrng=Cellinrng（ActiveCell）
如果InStr（1，arrng（0），“PrjRel”）=0，则
Application.DisplayAlerts=False
出口接头
其他的
如果ActiveCell.Row=Range（“Rev_Line”和Right（arrng（0）、Len（arrng（0））-6））（-4,0）。那么
Application.EnableEvents=False
Application.ScreenUpdating=False
暗电池
设置activcell=ActiveCell
调用sbUnProtectSheet（ActiveSheet.Name）
范围（Range（“Rev_线”）和右侧（arrng（0），Len（arrng（0））-6））（-1，ActiveCell.Column-2）。地址和“：”&范围（“Rev_线”和右侧（arrng（0），Len（arrng（0））-6））（1，ActiveCell.Column-2。地址）。复制
范围（Range（“Rev_Line”和Right（arrng（0），Len（arrng（0））-6））（-1，ActiveCell.Column-2）。地址和“：”&范围（“Rev_Line”和Right（arrng（0），Len（arrng（0））-6））（1，ActiveCell.Column-2。地址）。粘贴特殊值
Application.CutCopyMode=False
范围（Range（“Rev_线”）和右侧（arrng（0），Len（arrng（0））-6））（5，ActiveCell.Column-2）。地址和“：”&范围（“Rev_线”和右侧（arrng（0），Len（arrng（0））-6））（5，ActiveCell.Column-2。地址）。复制
范围（Range（“Rev_Line”和Right（arrng（0），Len（arrng（0））-6））（5，ActiveCell.Column-2）。地址和“：”&范围（“Rev_Line”和Right（arrng（0），Len（arrng（0））-6））（5，ActiveCell.Column-2。地址）。粘贴特殊值
Application.CutCopyMode=False
范围（Range（“Rev_Line”和Right（arrng（0），Len（arrng（0））-6））（8，ActiveCell.Column-2）。地址和“：”&范围（“Rev_Line”和Right（arrng（0），Len（arrng（0））-6））（8，ActiveCell.Column-2。地址）。复制
范围（Range（“Rev_Line”和Right（arrng（0），Len（arrng（0））-6））（8，ActiveCell.Column-2）。地址和“：”&范围（“Rev_Line”和Right（arrng（0），Len（arrng（0））-6））（8，ActiveCell.Column-2。地址）。粘贴特殊值
Application.CutCopyMode=False
范围（范围（“Rev_Line”和右（arrng（0），Len（arrng（0））-6））（10，ActiveCell.Column-2）。地址和“：”&范围（“Rev_Line”和右（arrng（0），Len（arrng（0））-6））（10，ActiveCell.Column-2。地址）。复制
范围（Range（“Rev_Line”和Right（arrng（0），Len（arrng（0））-6））（10，ActiveCell.Column-2）。地址和“：”&范围（“Rev_Line”和Right（arrng（0），Len（arrng（0））-6））（10，ActiveCell.Column-2。地址）。粘贴特殊值
Application.CutCopyMode=False
范围（“修订线”和右侧（arrng（0）、Len（arrng（0））-6））。选择
范围（“Rev_Rec”&右侧（arrng（0），Len（arrng（0））-6））.Formula=“=SUMIF（偏移量（$C”&（ActiveCell.Row-5）和“、0,0，Row（$C”&（ActiveCell.Row-5）和”）—Row（$C”&（ActiveCell.Row-5）和“+1，COLUMN（）），”实际“、Rev_行（$C”&（ActiveCell.Row-5）和右侧（arrng（0），Len（arrng.Row-6）和“）
范围（“Rev_Rec”&右侧（arrng（0），Len（arrng（0））-6））。复制
范围（“Rev_Rec”&右侧（arrng（0）、Len（arrng（0））-6））。粘贴特殊XLPaste值
Application.CutCopyMode=False
范围（“修订线”和右侧（arrng（0）、Len（arrng（0））-6））。选择
范围（“实际小时数”和右侧（arrng（0），Len（arrng（0））-6）。公式=“=SUMIF（偏移量（$D“&（ActiveCell.Row-5）和“，”0,0，Row（$D“&（ActiveCell.Row-5）和”）-Row（$D“&（ActiveCell.Row-5）和“）+1，COLUMN（）-COLUMN（$D“&（ActiveCell.Row-5）和”），”实际“，”sumRange“
范围（“实际小时数”&右侧（arrng（0），Len（arrng（0））-6）。复制
范围（“实际小时数”&右侧（arrng（0）、Len（arrng（0））-6））。粘贴特殊XLPaste值
Application.CutCopyMode=False
范围（“修订线”和右侧（arrng（0）、Len（arrng（0））-6））。选择
范围（“网络天数实际值”和右侧（arrng（0），Len（arrng（0））-6））.Formula=“=SUMIF（偏移量（$D“&（ActiveCell.Row-5）和“，”0,0，Row（$D“&（ActiveCell.Row-5）和”）—Row（$D“&（ActiveCell.Row-5）和”）+1，COLUMN（）-COLUMN（$D“&（ActiveCell.Row-5）和”），”实际值“，”sumRange“
范围（“网络天数实际值”&右侧（arrng（0），Len（arrng（0））-6））。复制
范围（“网络天数实际值”&右侧（arrng（0）、Len（arrng（0））-6））。粘贴特殊XLPaste值
Application.CutCopyMode=False
如果结束
如果结束
如果结束

您所采用的方法需要许多编码行，如果需要更改，则很难维护

我提出的解决方案使用

工作表\u Change

事件触发将公式更改为值和重述公式的过程，它还使用来标识需要处理的单元格。T

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

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