Excel VBA：如果单元格包含某些文本，则输入具有该内容的单元格范围

Question

想要搜索特定文本的列范围（“原因”），并在找到时将整个单元格内容填充到一系列不同的单元格中。

执行此操作，直到找到新的“ REASON”为止-在这种情况下，此单元格内容将像以前一样被复制。

这是在结果之前： before

...和预期结果，在J列中填充文本

谢谢大家，一直在弄弄这个，但不确定从这里去哪里

Sub AddSus()
Dim SrchRng As Range, cel As Range
Set SrchRng = Range("g1:g60")
For Each cel In SrchRng
  If InStr(1, cel.Value, "REASON") > 0 Then
     cel.Offset(1, 0).Value = cel.Value
  End If
Next cel
End Sub

Answer 1

使用FIND在 REASON 实例之间快速跳转：

Sub AddSus()

    Dim SrchRng As Range
    Dim rFound As Range
    Dim lStart As Long, lEnd As Long
    Dim sFirstAddress As String
    Dim sReason As String

    Set SrchRng = ThisWorkbook.Worksheets("Sheet1").Range("G:G")

    'Find the first instance of REASON in column G.
    Set rFound = SrchRng.Find(What:="REASON:", _
                       After:=SrchRng.Cells(1, 1), _
                       LookIn:=xlValues, _
                       LookAt:=xlPart, _
                       SearchOrder:=xlByRows, _
                       SearchDirection:=xlNext, _
                       MatchCase:=True)

    'Check something has been found before continuing.
    If Not rFound Is Nothing Then

        'Find just keeps looping unless you tell it to stop,
        'so record the first found address.
        sFirstAddress = rFound.Address
        Do
            'Save the reason and start row.
            sReason = rFound.Value
            lStart = rFound.Row

            'Find the next REASON in column G.
            Set rFound = SrchRng.FindNext(rFound)

            If rFound.Address = sFirstAddress Then
                'The first instance has been found again, so use column I to find last row of data.
                lEnd = SrchRng.Offset(, 2).Cells(Rows.Count, 1).End(xlUp).Row
            Else
                lEnd = rFound.Row
            End If

            'Fill in from 2 rows down from Start and 2 rows up from End.
            'This will go wrong if there's not enough space between REASONs.
            With ThisWorkbook.Worksheets("Sheet1")
                .Range(.Cells(lStart + 2, 10), .Cells(lEnd - 2, 10)) = sReason
            End With

        Loop While rFound.Address <> sFirstAddress
    End If

End Sub

Answer 2

这有一些问题。当您遍历cel in SrchRng时，您的条件正在检查该cel的值以包含“ REASON”。这不是您想要的。实质上，您要做的是检查“ REASON”字符串，并说出下面的所有条目，直到下一个原因，条件填充列J都应为真。

让我们简要地真正，通过一个单元格的逻辑来说明为什么您的代码没有按照您的要求做： 在单元格G3中，检查它是否包含“ REASON”字符串。它没有，所以在任何地方都没有赋值。以下将完成您想要的事情：

Sub AddSus()
Dim SrchRng As Range, cel As Range, reasonString As String
Set SrchRng = Range("g1:g60")
For Each cel In SrchRng
    If InStr(1, cel.Value, "REASON") > 0 Then
        reasonString = cel.Value
    ElseIf cel.Value <> "" Then
        cel.Offset(0, 3).Value = reasonString
  End If
Next cel
End Sub

次要注释，但是如果您在G列中并且要填充J列，则偏移量应为.offSet(0,3)。

Answer 3

一种快速而肮脏的解决方案...

Sub AddSus()

    Dim SrchRng As Range, cel As Range
    Dim reason As String

    Set SrchRng = Range("g1:g60")

    For Each cel In SrchRng

        If InStr(1, cel.Value, "REASON") > 0 Then
            reason = cel.Value
        End If

        If cel.Column = 10 And Len(cel.Offset(,-1)) > 0 Then
            cel.Value = reason
        End If

    Next

End Sub