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),"")

向下拖動...