VBA-在行中搜索字符串，然后将其复制并粘贴到其他列中

Question

_作为VBA的newby，我正在尝试从D列中搜索特定的字符串，然后将其复制并将该字符串粘贴到其他列中。 我大约有10,000个条目，因此手动执行效率不高。 我要查找的字符串是“ REQ0”和“ RITM0”。

这是我当前的代码：

Option Compare Text
Public Sub Search_For()
Dim cursht

cursht = ActiveSheet.Name
row_number = 1

Do

row_number = row_number + 1
item_description = Sheets(cursht).Range("D" & row_number)
items_copied = Sheets(cursht).Range("F" & row_number)

If InStr(item_description, "REQ0") Then
    Worksheets("cursht").Row(item_description).Copy
    items_copied.Paste
If InStr(item_description, "RITM") Then
    Worksheets("cursht").Row(item_description).Copy
    items_copied.Paste
End If

Loop Until items_description = ""

End Sub

预期成绩：

Answer 1

好吧，这是一种方法：

Sub Test()

Dim X As Long, LR As Long, POS1 As Long, POS2 As Long

With ActiveWorkbook.Sheets(1)
    LR = .range("D" & Rows.Count).End(xlUp).Row
    For X = 2 To LR
        If InStr(1, .Cells(X, 4), "REQ0") > 0 Then
            POS1 = InStr(1, .Cells(X, 4), "REQ0") 'Get startposition
            POS2 = InStr(POS1, .Cells(X, 4), " ") 'Get positon of space
            If POS2 > 0 Then 'In case there is a space
                .Cells(X, 5) = Mid(.Cells(X, 4), POS1, POS2 - POS1)
            Else 'In case the found value is at end of string
                .Cells(X, 5) = Right(.Cells(X, 4), Len(.Cells(X, 4)) - (POS1 - 1))
            End If
        End If
        If InStr(1, .Cells(X, 4), "RITM") > 0 Then 'Repeat same process for "RITM"
            POS1 = InStr(1, .Cells(X, 4), "RITM")
            POS2 = InStr(POS1, .Cells(X, 4), " ")
            If POS2 > 0 Then
                .Cells(X, 6) = Mid(.Cells(X, 4), POS1, POS2 - POS1)
            Else
                .Cells(X, 6) = Right(.Cells(X, 4), Len(.Cells(X, 4)) - (POS1 - 1))
            End If
        End If
    Next X
End With

End Sub

使用“复制/粘贴”将大大减慢您的过程。

编辑

更好的方法可能是只使用公式

在E2中键入以下公式：

=IF(ISNUMBER(SEARCH("*REQ0*",D2)),MID(D2,FIND("REQ0",D2),11),"")

并将此公式放在F2中：

=IF(ISNUMBER(SEARCH("*RITM*",D2)),MID(D2,FIND("RITM",D2),11),"")

向下拖动...