是否有办法将一个工作表上的一个单元格设置为等于另一个工作表上的一个单元格，基于特定单元格的值?

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重新启动。

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