excel - 有没有办法根据特定单元格的值将一个工作表上的一个单元格设置为另一个工作表上的一个单元格？

Question

所以我有一个下拉菜单来选择年份；2015、2016、2017 等，但根据选择的年份，我想填充特定工作表中的单元格。因此，例如，如果选择 2015，则当前工作表中的单元格 K3 等于 2015 工作表中的单元格 E12。任何帮助将不胜感激，谢谢！

编辑：

到目前为止，我有以下 VBA 代码：

 Option Explicit
 Sub Worksheet_Change(ByVal Target As Range)

 If Range("J2") = "2016" Then
     Range("K3") = ActiveWorkbook.Worksheets("2016").Range("E12")
 Else
     Range("K3") = "0"
 End If

 End Sub

...但不断收到此错误：

 Run-time error '1004':

 Method 'Range' of object '_Worksheet' failed

...然后 Excel 重新启动。

标签： excelvba

Answer 1

下拉工作表更改

• 在最初的解决方案中，当写入目标单元格时，事件将被重新触发。虽然它会以这If Intersect...条线结束，但我认为它是不可接受的（错误的）。研究以下解决方案如何避免这种情况。
• 要查看（证明）差异，您可以MsgBox "Entering Change Event"在每个代码的开头添加例如该行，这将表明错误的解决方案会在下拉单元格中的每次更改时显示两次消息框。

更正和改进

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    Const sAddress As String = "E12" ' Source Cell (read from)
    
    Const dddAddress As String = "J2" ' Destination Drop-Down Cell
    Const dAddress As String = "K3" ' Destination Cell (written to)
    Const dValNoWorksheet As Long = 0 ' source worksheet not found
    Const dValBlank As Long = 0 ' source cell blank i.e. [Empty],[=""],['],...)
    
    Dim dddCell As Range: Set dddCell = Range(dddAddress)
    ' This will prevent the succeeding code to run if there was no change
    ' in the drop-down cell.
    If Intersect(Target, dddCell) Is Nothing Then Exit Sub ' not ddd cell
    
    ' 'Me' is the worksheet containing this code, while 'Me.Parent' is
    ' its workbook which is also 'ThisWorbook'.
    On Error Resume Next ' defer error trapping
    Dim sws As Worksheet: Set sws = Me.Parent.Worksheets(CStr(dddCell.Value))
    On Error GoTo 0 ' enable error trapping ('Err.Number = 0')
    
    ' The following line prevents triggering the event again when writing
    ' to the destination cell ('dCell').
    Application.EnableEvents = False
    ' Immediately after the previous line start an error-handling routine
    ' to prevent exiting the procedure with events disabled. Its flow
    ' is self-explanatory but study it carefully.
    On Error GoTo ClearError ' enable error trapping
    
    ' Now you do your thing. If something goes wrong, the error handler
    ' will make make sure that the procedure will exit only after enabling
    ' events.
    
    Dim dCell As Range: Set dCell = Range(dAddress)
    
    If sws Is Nothing Then ' worksheet doesn't exist
        dCell.Value = dValNoWorksheet
    Else ' worksheet exists
        Dim sCell As Range: Set sCell = sws.Range(sAddress)
        If Len(CStr(sCell.Value)) = 0 Then ' blank
            dCell.Value = dValBlank
        Else ' not blank
            dCell.Value = sCell.Value
        End If
    End If

SafeExit:
    ' Be careful, if an error occurs here, it will trigger an endless loop,
    ' since the error handler is still active.
    Application.EnableEvents = True
    
    Exit Sub

ClearError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    Resume SafeExit ' the error handler stays active('Err.Number = 0')

End Sub

错误的

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Intersect(Target, Range("J2")) Is Nothing Then Exit Sub ' not dd cell
    
    On Error Resume Next
    Dim ws As Worksheet: Set ws = Me.Parent.Worksheets(CStr(Range("J2").Value))
    On Error GoTo 0

    If ws Is Nothing Then ' worksheet doesn't exist
        Range("K3").Value = 0
    Else ' worksheet exists
        If Len(CStr(ws.Range("E12").Value)) = 0 Then ' blank
            Range("K3").Value = 0
        Else ' not blank
            Range("K3").Value = ws.Range("E12").Value
        End If
    End If

End Sub