0

场景：

我有两个相同的工作表，除了 Sheet2 列 CE 中的“一些内容”和包含 Worksheet_SelectionChange 处理程序的 Sheet1

当我单击 Sheet1 中的 B 列时，Worksheet_SelectionChange 会更改单元格颜色，然后将 CE 列设置为 Sheet2 列 C

问题：

麻烦的是它会因应用程序错误而崩溃...

谁能帮忙，这真的很烦人......我如何在 Worksheet_SelectionChange 处理程序中将数据从 Sheet2 复制到 Sheet 1？

如果我设置 S1C = "X" （如硬编码那样很好），那么当我尝试从第二张表中引用单元格时它不起作用。

非常感谢提前，最好的问候

代码如下：

Public benRel
Public rskOpt
Public resOpt
Public getRow
Public getCol

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

On Error GoTo ExitSubCorrectly
'turn off multiple recurring changes
Application.EnableEvents = False

'do not allow range selection
If Target.Cells.Count > 1 Then GoTo ExitSubCorrectly


'only allow selection within our range
Set myRange = Range("B8:B24")
If Not Application.Intersect(Target, myRange) Is Nothing Then
    ' At least one cell of Target is within the range myRange.
    ' Carry out some action.

    getRow = Target.Row
    getCol = Target.Column


    Select Case Range(Cells(Target.Row, Target.Column), Cells(Target.Row, Target.Column)).Style

        Case "Normal"
            Range(Cells(Target.Row, Target.Column), Cells(Target.Row, Target.Column)).Style = "Accent1"

            getData
            putData

        Case "Accent1"
            Range(Cells(Target.Row, Target.Column), Cells(Target.Row, Target.Column)).Style = "Normal"
            Range(Cells(Target.Row, Target.Column + 1), Cells(Target.Row, Target.Column + 3)).Value = ""

        Case Else

    End Select

Else
    ' No cell of Target in in the range. Get Out.
    GoTo ExitSubCorrectly
End If

ExitSubCorrectly:
' go back and turn on changes
' MsgBox Err.Description
Worksheets("Sheet1").Select
Application.EnableEvents = True

End Sub

Sub getData()

Worksheets("Sheet2").Select
Range(Cells(getRow, getCol), Cells(getRow, getCol)).Select
benRel = Range(Cells(getRow, getCol), Cells(getRow, getCol)).Offset(0, 1).Value
rskOpt = Range(Cells(getRow, getCol), Cells(getRow, getCol)).Offset(0, 2).Value
resOpt = Range(Cells(getRow, getCol), Cells(getRow, getCol)).Offset(0, 3).Value


End Sub

Sub putData()

Worksheets("Sheet1").Select
Range(Cells(Target.Row, Target.Column), Cells(Target.Row, Target.Column)).Offset(0, 1).Value = benRel
Range(Cells(Target.Row, Target.Column), Cells(Target.Row, Target.Column)).Offset(0, 2).Value = rskOpt
Range(Cells(Target.Row, Target.Column), Cells(Target.Row, Target.Column)).Offset(0, 3).Value = resOpt

End Sub
4

1 回答 1

1

在我看来，您可以将所有三个例程都替换为

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

   On Error GoTo ExitSubCorrectly
   'turn off multiple recurring changes
   Application.EnableEvents = False

   'do not allow range selection
   If Target.Cells.Count > 1 Then GoTo ExitSubCorrectly

   'only allow selection within our range
   Set myRange = Range("B8:B24")
   If Not Application.Intersect(Target, myRange) Is Nothing Then
      ' At least one cell of Target is within the range myRange.
      ' Carry out some action.
      With Cells(Target.Row, Target.Column)
         Select Case .Style

            Case "Normal"
               .Style = "Accent1"
               .Offset(0, 1).Resize(, 3).Value = Worksheets("Sheet2").Cells(getRow, getCol).Offset(0, 1).Resize(, 3).Value
            Case "Accent1"
               .Style = "Normal"
               .Offset(0, 1).Resize(, 3).ClearContents
            Case Else

         End Select
      End With

   End If

ExitSubCorrectly:
   ' go back and turn on changes
   ' MsgBox Err.Description
   Application.EnableEvents = True

End Sub
于 2013-09-04T12:45:01.437 回答