如何查找使用“颜色”突出显示的所选活动单元格，并将上面单元格中提供的数据复制到某个特殊的指定单元格

Question

我是VBA的新手，所以如果有人帮助我解决我的问题，那么我会非常感激，因为我坚持了下来。 enter image description here 请看下面的附图，如果有人为我提供VBA代码，那么对我来说真的很有帮助。任务包含以下步骤。

1-在第11行中，相应列中提供了日期。像16 / 11,17 / 11,18 / 11等。

2-从第（12到29行）我提供了不同的任务。

我的任务是。

1-当我选择任何单元格/框时，用任何颜色填充该单元格上方（第10行）中可用的日期（自动进行/复制）到该任务所提到的指定单元格。 例如：我选择第21行AQR表示单元格，并通过填充颜色突出显示它，以便该单元格上方的日期自动进行/复制到上面提到的AQR演示文稿的指定单元格，同样我也需要处理每个单元格。

请求：

我需要一个代码来检测突出显示的活动单元格，并将该单元格上方的日期发送到上面提到的指定文件夹。

请参阅该图以获得更清晰的理解。

如果有人帮我提供此代码，我将不胜感激。

Answer 1

我认为不可能与您的要求完全匹配;当然我不知道如何提供完全匹配。但是，我认为可能有一些非常相似的东西，我认为这比你的要求更方便。

您需要使用事件例程。 Excel将“打开工作簿”，“激活工作表”，“更改选择”以及许多其他内容标识为事件。对于任何Excel事件，您可以在VBA中编写一个例程，Excel将在该事件发生时执行。

如果打开Excel的VB编辑器并单击 F2 ，您将获得所有类及其成员的列表。向下滚动“类”列表，直至到达“工作表”。右侧的列表将显示Worksheet类的所有成员。对他们有闪电符号的是事件：Activate，BeforeDelete，BeforeDoubleClick，BeforeRightClick，Calculate等。如果您在自己喜欢的搜索引擎中键入“excel vba工作表之前的双击事件”，您将获得解释该事件的网页，并通常给出该事件例程的示例。我发现文档有点模糊，我通常不得不尝试一个不熟悉的事件。

我已经为WorkBook Open事件和Worksheet Activate，Right Right Click和Selection Change事件编写了事件例程。不幸的是，没有“工作表更改单元格颜色”事件，所以我使用了“右键单击前工作表”事件。

打开VB Editor后，您将看到左侧的Project explorer。如果看不到，请单击 Ctrl + R 。您将看到的内容将是：

- VBAProject(Xxxxx.xlsm)
  - Microsoft Excel Objects
     Sheet1 (Kick off)
     Sheet2 (Sheet2)
     ThisWorkbook

您将拥有更多工作表，可能是一些用户表单和一些模块，但它们暂时无关紧要。如果您可以看到我显示减号的加号，请单击它以展开列表。我已经创建了一份启动工作表的副本，我将其命名为“Kick off”。你可能有一个不同的名字，但我会称之为“开球”。单击“Sheet1（启动）”，右侧将出现一个白色区域。这是为此工作表保留的代码区域。每个工作表都有类似的代码区域。如果单击“ThisWorkbook”，您将获得另一个代码区域。您可以将此代码区域用作普通模块，但我建议不要这样做。此代码区域应保留用于某些工作簿级别例程。

将此代码放在ThisWorkbook代码区域中：

Option Explicit
Sub Workbook_Open()

  If ActiveSheet.Name = "Kick off" Then
    Worksheets("Sheet1").Activate
    Worksheets("Kick off").Activate
  End If
End Sub

打开工作簿时，将自动执行此代码区域中名称为Workbook_Open的例程。将“Kick off”替换为此工作表的名称，并将“Sheet1”替换为任何其他工作表的名称。

如果工作簿“Kick off”在保存工作簿时处于活动状态，则在打开工作簿时不会自动执行其Activate例程。此代码的唯一目的是强制执行“启动”激活例程。

以下代码都属于Worksheet“Kick off”的代码区域。此代码不会完全按照您的要求执行，因此我将尝试详细解释它以使其适应您的要求，

我的代码以行和列的一些常量开头。例如：

  Const RowDate As Long = 11        ' Row holding dates

目前，您的日期在第11行，但在开发系统时可能会轻易更改。如果您修改工作表，以便第13行保存日期，只需更新此常量语句，您的代码就会完全更新。比扫描你的代码对文字11的所有用法要容易得多。

接下来我有一些颜色常量。如果你不喜欢我的颜色，请修改这些不变的陈述。

接下来是一些Dim声明。例程中声明的变量在例程退出时被销毁。在例程外声明的变量具有更长的寿命。我不知道这些变量是否会持续到工作簿关闭或激活另一个工作表为止。不要紧;它们持续足够长的时间，允许我将值从一个事件例程调用传递给另一个调用。

接下来是Private Sub Worksheet_Activate()。如果您的用户切换到另一个工作表，则会在切换回时自动调用此例程。它记录活动单元的位置并加载三个数组。这三个数组及其值是：

  Array entries ->    0   1
  RowActionSrc       16  21 
  RowActionDest       2   3
  ColActionDest      25  25

这些数组的使用方式是经验丰富的程序员的常用技术，但对您来说可能是新手。如果在第16行或第21行上进行选择，则需要执行特殊操作。这些行可能会更改，以后可能需要对其他行执行类似的操作。通过使用单个语句将这些行号加载到数组中，可以很容易地更改它们或添加它们。如果选择了第16行上的单元格，则需要将其日期复制到第2行第25列。如果选择了第21行上的单元格，则需要将其日期复制到第3行第25列。这些目标可能不是您想要的但它们很容易改变，所以无关紧要。我编写了Worksheet_BeforeRightClick来使用这些数组中的数字将所需日期移动到所需的单元格。

暂时翻阅Worksheet_BeforeRightClick，此代码中的最后一个例程为Worksheet_SelectionChange。我不确定这是不是一个好主意。此例程提供的功能是导致此代码中大部分复杂性的原因。我决定保留这些功能，因为我认为它很有用，因为它可以很好地演示事件例程可以做什么。这是我的启动工作表的图像：

它有点小但是足够用于此目的并不完全匹配你的但是足够接近。活性细胞当前是细胞Z21。您会注意到此单元格的任务和日期已着色。当我刚开始时，我发现很难将活动单元格与其任务和日期相匹配。着色任务和日期使得它变得更加容易。这就是Worksheet_SelectionChange的作用。当用户移动活动单元格时，将自动调用此例程以从旧任务和日期中删除颜色并为新任务和日期着色。正如我所说的，我相信这个功能既有用又可以很好地演示如何使用事件例程来定制Excel体验。

返回Worksheet_BeforeRightClick;这是一个例程，它提供的功能是我能达到你所要求的最接近的匹配。正如我所说，没有基于着色细胞的事件。即使有，我也不确定我会觉得方便。我必须选择Home标签，然后选择Fill Color，然后选择我想要的颜色，然后才能触发事件。使用Before Right Click事件，我使用箭头键或鼠标或 F5 或我希望选择我想要激活的单元格。然后我单击鼠标右键。事件例程使用标准颜色为单元格着色并复制日期。

试验我的代码。试着弄清楚它是如何实现目标的。尽可能回答问题，但是你可以自己解决的问题越多，你就越能发展自己的技能。

Option Explicit

  ' I define these column and row numbers as constants in case they change.
  ' If they do change, one amendment here and the code is updated. If the
  ' literal is used in the code, you have to search for and fix every use
  ' to update the code.
  Const ColDateFirst As Long = 3    ' The first column with a date
  Const ColTaskName As Long = 1     ' Column holding task names
  Const RowDate As Long = 11        ' Row holding dates
  Const RowTaskFirst As Long = 12   ' First row containing tasks

  ' Warning: If you change any of these colours, the values are BBGGRR which
  ' is Excel's standard and not RRGGB which is everyone else's standard.
  Const ClrCrntHeader As Long = &H99CCFF        ' Tan
  Const ClrSelectedCell As Long = &HFFFF&       ' Yellow

  ' The position of the active cell is recorded in these variable so
  ' when the active cell changes the old position is known. This is
  ' necessary to correctly maintain the row and column headers. If
  ' the row and column headers were not highlighted, these variables
  ' would not be needed.
  Dim ColPrev As Long
  Dim RowPrev As Long

  ' These arrays are loaded by Worksheet_Activate().  See that routine
  ' for an explanation of these arrays.
  Dim RowActionSrc() As Variant
  Dim RowActionDest() As Variant
  Dim ColActionDest() As Variant
Private Sub Worksheet_Activate()

  ' This routine is called when the worksheet is activated (selected)

  ' * If the active cell is within the monitored area, the header row and
  '   column will already be hightlighted. Record the current position of
  '   the active cell in ColPrev and RowPrev.
  ' * Load RowAction and ColAction arrays
  ' * The monitored area is ColDatFirst and right and RowTaskFirst amd down.

  Application.EnableEvents = False

  If ActiveCell.Row >= RowTaskFirst And ActiveCell.Column >= ColDateFirst Then
    ' Active cell was within the monitored area when the workbook was closed or
    ' the user switched to another worksheet. The appropriate row and column
    ' headers will still be highlighted.
    ColPrev = ActiveCell.Column
    RowPrev = ActiveCell.Row
  Else
    ' The active cell was outside the monitored area. No row or column header
    ' is highlighted
    ColPrev = 0
    RowPrev = 0
  End If

  ' If the active cell is right clicked when it is in one of the rows
  ' listed in RowActionSrc:
  '   1) The active cell is coloured ClrSelectedCell
  '   2) The date above the active cell is copied to the row and column
  '      specified in the cell specified by the matching positions
  '      in RowActionDest and ColActionDest.
  RowActionSrc = VBA.Array(16, 21)
  RowActionDest = VBA.Array(2, 3)
  ColActionDest = VBA.Array(25, 25)
  ' For example:
  '  * If cell(16,20) is right clicked, the date in cell(11, 20) is copied
  '    to cell(2,25).
  '  * If cell(21,27) is right clicked, the date in cell(11, 27) is copied
  '    to cell(3,25).


  Application.EnableEvents = True

End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

  ' * The active cell has been right clicked.
  ' * If the active cell is within the monitored area and if active row is
  '   specified in RowActionSrc, copy the data above the active cell to the
  '   specified destination cell.

    Dim CellColoured As Range

  Application.EnableEvents = False

  Dim InxC As Long

  If ActiveCell.Row >= RowTaskFirst And ActiveCell.Column >= ColDateFirst Then
    ' Active cell was within the monitored area
    For InxC = 0 To UBound(RowActionSrc)
      If RowActionSrc(InxC) = ActiveCell.Row Then
        ' The active cell is in a row for which the date above it is to be
        ' copied to a specified destination. In addition, the active cell is
        ' to be coloured

        ' First remove colour from any previously selected cell
        Application.FindFormat.Interior.Color = ClrSelectedCell
        Do While True
          ' What:="*" will only match cells with a value
          ' What:="" will match cells with or without a value
          Set CellColoured = Rows(ActiveCell.Row).Find(What:="", SearchFormat:=True)
          If CellColoured Is Nothing Then
            Exit Do
          End If
          CellColoured.Interior.ColorIndex = xlNone    ' Remove colour
          CellColoured.Value = ""                      ' Remove value if any
        Loop

        ' Colour selected cell
        Cells(ActiveCell.Row, ActiveCell.Column).Interior.Color = ClrSelectedCell
        ' Move date for active column to specified cell
        Cells(RowActionDest(InxC), ColActionDest(InxC)).Value = Cells(RowDate, ActiveCell.Column).Value
      End If
    Next
  End If

  Cancel = True  ' Surpress default action for Right Click

  Application.EnableEvents = True

End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

  Application.EnableEvents = False

  ' A new cell has been selected; that is, there is a new active cell.

  If ColPrev <> 0 Then
    ' Remove highlighting from previous task name and date
    Cells(RowPrev, ColTaskName).Interior.ColorIndex = xlNone
    Cells(RowDate, ColPrev).Interior.ColorIndex = xlNone
  End If

  If ActiveCell.Row >= RowTaskFirst And ActiveCell.Column >= ColDateFirst Then
    ' Active cell is within the monitored area
    ColPrev = ActiveCell.Column
    RowPrev = ActiveCell.Row
    ' Highlight task name and date
    Cells(RowPrev, ColTaskName).Interior.Color = ClrCrntHeader
    Cells(RowDate, ColPrev).Interior.Color = ClrCrntHeader
  Else
    ColPrev = 0   ' No previous active cell
    RowPrev = 0
  End If

  Application.EnableEvents = True

End Sub

附加功能说明

原始代码会为通过右键单击选择的单元格着色，但不会从先前选定的单元格中删除颜色。新代码定位活动行中的任何单元格ClrSelectedCell（=黄色=＆amp; HFFFF＆amp;）并删除颜色和值（如果有）。

Find通常用于搜索值，但可以搜索格式。如果格式搜索功能有任何体面的文档，我找不到它。额外的代码是通过实验而不是遵循官方指示开发的。此代码已使用Excel 2016进行测试，但我没有理由相信它不适用于早期版本。

更改包含一个新变量（Dim CellColoured As Range），并且在新选择的单元格着色之前包含此代码：

    Application.FindFormat.Interior.Color = ClrSelectedCell
    Do While True
      ' What:="*" will only match cells with a value
      ' What:="" will match cells with or without a value
      Set CellColoured = Rows(ActiveCell.Row).Find(What:="", SearchFormat:=True)
      If CellColoured Is Nothing Then
        Exit Do
      End If
      CellColoured.Interior.ColorIndex = xlNone    ' Remove colour
      CellColoured.Value = ""                      ' Remove value if any
    Loop 

应该只有一个以前有色的单元格，但是这个代码循环所以以前所有颜色的单元格都被清除了颜色和值。

注意：我使用ColorIndex = xlNone而不是Colour = vbWhite清除颜色。如果将单元格的颜色设置为白色，则会丢失边框，但如果将颜色索引设置为无，则不会丢失。

Answer 2

在VBA中定义一个函数：

Function NOTWHITE(rng As Range) As Boolean
    Application.Volatile
    If rng.Interior.ColorIndex = xlNone Or rng.Interior.Color = vbWhite Then
        NOTWHITE = False
    Else
        NOTWHITE = True
    End If
End Function

然后将以下公式放入D12并复制粘贴到您希望表现的所有其他单元格：

=IF(NOTWHITE(D12); D$11; "")

但是，您需要在每次更改后通过F9重新计算工作表。