If cell contains several specific text, then copy and paste. how to do it?

Question

 A COLUMN                --> A cloumn (ANOTHER SHEET)      -->  A COLUMN   F COLUMN
 21982-usd-12                21982-usd-12                       21982       USD
 21827-yp-0                  21827-yp-0                         21827       YP
 21981-NCK-12                21312-hx-101                       21312       HX
 21311-XLM-13
 1231xcv
 123123zcxv
 21312-hx-101
 hello

If the cells contain "usd" or "yp" or "hx" in a column, then copy only that cells and paste to range("a2") in another sheet . (paste to "lastrow + 1")

and that cells' 5 digit(ex 21982 (only 5 digit) left in a column, "usd" or "yp" or "hx" move to f column.

i want to make a code.. but that is hard..

Did you try something on your own? Looking to the example, it does not completely match your question description... So, should be processed only cells having a pattern like xxxxx-y-z? Where the digits number of y and z does not matter... Then, would the cells which match the rule be placed in consecutive rows, or in the same row like in the sheet where they have been found? — FaneDuru, Sep 03 '20 at 06:54
It is not clear that you need to copy (in another sheet) all the string (21982-usd-12), or the split string (21982 in A:A and USD in F:F). Do you want saying to initially copy the whole string and only then to split it? Can you clarify this aspect, too? — FaneDuru, Sep 03 '20 at 07:02

FaneDuru · Answer 1 · 2020-09-03T07:37:09.727

Try the next code, please. It uses arrays and should be very fast for big ranges. It works only in memory and drops the processing result at once:

Sub testExtractText()
 Dim sh As Worksheet, sh1 As Worksheet, lastRow As Long, lastRow2 As Long, arr As Variant
 Dim arrFinA As Variant, arrFinF As Variant, arrSearch As Variant, El As Variant, i As Long, k As Long
 
 Set sh = Worksheets("sheet to be processed")        'use here your sheet
 Set sh1 = Worksheets("sheet to receive the return") 'use here your sheet
 lastRow = sh.Range("A" & Rows.count).End(xlUp).row
 arrSearch = Split("usd,yp,hx", ",")
 
 arr = sh.Range("A2:A" & lastRow).value
 
 ReDim arrFinA(1 To 1, 1 To lastRow) 'reverse rows with columns to finally ReDim Preserve
 ReDim arrFinF(1 To 1, 1 To lastRow)
 k = 1
 For i = 1 To UBound(arr)
    For Each El In arrSearch
        If InStr(arr(i, 1), "-" & El & "-") > 0 Then
            arrFinA(1, k) = Split(arr(i, 1), "-")(0)
            arrFinF(1, k) = UCase(Split(arr(i, 1), "-")(1))
            k = k + 1: Exit For
        End If
    Next
 Next i
 ReDim Preserve arrFinA(1 To 1, 1 To k - 1) 'keep only the filled elements
 ReDim Preserve arrFinF(1 To 1, 1 To k - 1)

 lastRow2 = sh1.Range("A" & Rows.count).End(xlUp).row + 1
 sh1.Range("A" & lastRow2).Resize(UBound(arrFinA, 2), 1).value = WorksheetFunction.Transpose(arrFinA)
 sh1.Range("F" & lastRow2).Resize(UBound(arrFinF, 2), 1).value = WorksheetFunction.Transpose(arrFinF)
End Sub

Please, take care to appropriately change the necessary sheets name (sh and sh1).

@dream chip: Glad I could help! But, we here when somebody answer our question, tick the code left side check box, in order to make it **accepted answer**. In this way, somebody else searching for a similar issue will know that the code works. My answer, or another one you like better. — FaneDuru, Sep 04 '20 at 04:52

score 0 · Answer 2 · answered Sep 03 '20 at 07:14

try this

Sub Splitter()
    Dim SourceSheet As Worksheet
    Dim DestSheet As Worksheet
    Dim RowCnt As Integer, LastRow As Integer
    Dim DestRow As Integer
    Dim Str As String
    
    Set SourceSheet = ActiveWorkbook.Sheets("Sheet1")
    Set DestSheet = ActiveWorkbook.Sheets("Sheet2")
    
    LastRow = SourceSheet.Range("A" & Cells.Rows.Count).End(xlUp).Row
    DestRow = DestSheet.Range("A" & Cells.Rows.Count).End(xlUp).Row + 1
    
    For RowCnt = 1 To LastRow
        Str = SourceSheet.Range("A" & RowCnt).Value
        If InStr(1, Str, "usd", vbTextCompare) > 1 Or _
            InStr(1, Str, "yp", vbTextCompare) > 1 Or _
            InStr(1, Str, "hx", vbTextCompare) > 1 Then
            DestSheet.Range("A" & DestRow) = Left(Str, InStr(1, Str, "-", vbTextCompare) - 1)
            DestSheet.Range("F" & DestRow) = Mid(Str, InStr(1, Str, "-", vbTextCompare) + 1, InStrRev(Str, "-", , vbTextCompare) - InStr(1, Str, "-", vbTextCompare) - 1)
            DestRow = DestRow + 1
        End If
    Next
End Sub

Row and column counters have to be of type `Long`, Excel has more rows than `Integer` can handle. Also see [here](https://stackoverflow.com/questions/26409117/why-use-integer-instead-of-long/26409520#26409520) why it is recommended always to use `Long` in VBA. — Pᴇʜ, Sep 03 '20 at 07:34

score 0 · Answer 3 · edited Sep 03 '20 at 09:32

First you need to give a name to your range.

Let's say you have a range A1:A15 named as "test"

Function StringExists(name As String, address As Range)   
    Dim cell As Range
    StringExists = False    
    For Each cell In address
        If (name = cell.Value) Then
            StringExists = True
        Else
        End If
    Next cell
 End Function


// if string exists then 

Dim name As String
    Dim address As Range

    name = InputBox("Enter string to search")
    Set address = Application.InputBox(prompt:="Enter range", Type:=8)
    If StringExists(name, address) Then
            MsgBox (name & "  Found in the range")
    Else
       MsgBox (name & "  could not be found in the range")
    End If

If cell contains several specific text, then copy and paste. how to do it?

3 Answers3