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

Question

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

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

这是之前的结果： 之前

...和预期结果，在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 in SrchRng您的条件正在检查该cel的值以包含“ REASON”。 这不是您想要的。 实际上，您要做的是检查“ REASON”字符串，并说出下面的所有条目，直到下一个原因，对于有条件填充列J的条件都应该为true。

让我们， 真的很简单，通过一个单一的单元的逻辑运行，说明为什么你的代码是不是做你想要的：在单元格G3，你检查，看它是否包含了“理性”的字符串。 它没有，所以在任何地方都没有赋值。 以下将执行您想要的操作：

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