Excel VBA：如果单元格是彩色的，则输出单元格行和列标题

Question

我刚接触VBA，已经为这个问题苦苦挣扎了两个星期。

每次名称通过培训后，相应的名称/培训标题单元格就会用日期填充，背景会用黄色RGB（255,255,0）填充。在进行IN培训时，他们的背景是黄色，没有日期。 （还有一些过期的红色或灰色，但我想我已经解决了这些问题。）

最终目标是在同一文件中有一个单独的输出表。此工作表的顶部仅包含必要的培训标题，如果它们是空白的黄色单元格（无日期+黄色），则在其下方将包含所有名称。最终，我希望能够将此列表通过电子邮件发送给某些人，但是我认为有足够的资源来弄清楚自己。

当前，我有代码来查找列/行的最大值/最小值，并且有删除所有包含日期​​的单元格的代码。我的计划是让它扫描剩余的黄色单元格，然后将训练标题/名称粘贴到新的工作表上，但是我无法弄清楚如何在VBA中做到这一点。

我确信必须有一种更简便的方法，因为它宽了几百列，长了几行。

感谢您的输入！

编辑：这是我当前正在使用的代码。这样会扫描名称范围和训练范围，并清除单元格数据（如果它是黄色以外的其他任何颜色，或者它是带有日期的黄色）。

我附上一张图片，以帮助您更清楚地解释。重要的单元格是没有日期的黄色单元格。在这些单元格中，我需要按照在图片中看到的方式，将训练标题和第A栏中的人员名称粘贴到新工作表上。

Sub ClearCellMacro()

Dim myLastCell As Range
Dim cell As Range

Application.ScreenUpdating = False

'Find last cell
Set myLastCell = Range("C4").SpecialCells(xlLastCell)

'Make sure last cell is outside of first row and column (or else exit)
If myLastCell.Row = 1 Or myLastCell.Column = 1 Then Exit Sub

'Loop through entire range removing cell contents if value is not numeric
For Each cell In Range("C4:" & myLastCell.Address)
    If Not IsNumeric(cell) Then cell.Clear
Next cell

For Each cell In Range("C4:" & myLastCell.Address)
    If cell.Interior.Color <> RGB(255, 255, 0) Then cell.Clear
Next cell

Application.ScreenUpdating = True

MsgBox "Non-Yellow + Blank Cells Removed."

End Sub

Answer 1

这不会清除非数字单元格。我假设已经完成了。

空白且突出显示为黄色的任何单元格都将被移到Sheet2上具有相应名称的表格中。

您需要更新代码的第3行和第4行以反映实际的工作表名称（请务必保留引号）。 Sheet1反映出照片中的“起始表”，而Sheet2反映出所需的输出。

这是按行和列动态的。最后一行（lRow）由Column A确定，最后一列（lCol）由Row 1确定。下面的宏产生的起点和输出的照片。

Option Explicit

Sub TestMe()

Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")

Dim lCol As Long: lCol = ws1.Cells(1, ws1.Columns.Count).End(xlToLeft).Column
Dim lRow As Long: lRow = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row

Dim myRange As Range, myCell As Range, myUnion As Range
Dim i as Long

For i = 3 To lCol 'Open column loop
Set myRange = ws1.Range(ws1.Cells(4, i), ws1.Cells(lRow, i))
    For Each myCell In myRange 'Open row loop
        If myCell = "" And myCell.Interior.Color = 65535 Then
            If myUnion Is Nothing Then
                Set myUnion = myCell.Offset(0, -i + 1)
            Else
                Set myUnion = Union(myUnion, myCell.Offset(0, -i + 1))
            End If
        End If
    Next myCell 'Next Row

    If Not myUnion Is Nothing Then 'This will need some updating to dynamically paste in first available column
        ws2.Cells(1, i - 2).Value = ws1.Cells(1, i).Value
        myUnion.Copy
        ws2.Cells(2, i - 2).PasteSpecial xlPasteValues
        Set myUnion = Nothing
    End If

Next i 'Next Column

End Sub