Question

这可能是一个非常糟糕的问题。我想指出我对VBA很新。通过在这里和那里查看互联网，我设法创建以下代码，我用它来突出显示包含特定日期的所有单元格。我现在想调整我的代码并将highlighnt扩展到包含特定日期的单元格的行，以便稍后我可以轻松地将它们复制并通过它们进入新选项卡。

Sub HighlightSpecificValue()

Dim fnd As String, FirstFound As String
Dim FoundDate As Range, rng As Range
Dim myRange As Range, LastCell As Range
Dim datetoFind As Date

'Value to be found
fnd = InputBox("Emter the date to be found", "Highlight")

'End Macro if Cancel Button is Clicked or no Text is Entered
  If fnd = vbNullString Then Exit Sub

'Convert String value to date format
 datetoFind = DateValue(fnd)

Set myRange = Sheets("Tabelle1").Range("E:E")
Set LastCell = myRange.Cells(myRange.Cells.Count)
Set FoundDate = myRange.Find(what:=datetoFind, _
                        after:=LastCell, _
                        LookIn:=xlFormulas, _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False, _
                        SearchFormat:=False)

'Test to see if anything was found
If Not FoundDate Is Nothing Then
FirstFound = FoundDate.Address
Else
GoTo NothingFound
End If

Set rng = FoundDate

'Loop until cycled through all unique finds
Do Until FoundDate Is Nothing
'Find next cell with fnd value
  Set FoundDate = myRange.FindNext(after:=FoundDate)

'Add found cell to rng range variable
  Set rng = Union(rng, FoundDate)

'Test to see if cycled through to first found cell
  If FoundDate.Address = FirstFound Then Exit Do

Loop

'Highlight Found cells yellow
rng.Interior.Color = RGB(255, 255, 0)

'Report Out Message
MsgBox rng.Cells.Count & " cell(s) were found containing: " & fnd

Exit Sub

'Error Handler
NothingFound:
MsgBox "No cells containing: " & fnd & " were found in this worksheet"

End Sub

提前感谢您的宝贵帮助！

Answer 1

使用EntireRow对象的Range方法。

rng.EntireRow.Interior.Color = RGB(255, 255, 0)

将突出显示从单元格扩展到行

1 个答案: