[Solved] If cell in column contains specific word then cut the row of the specific word [closed]

by


Try the next code, please (adapted to search in C:C the string occurrence):

Sub TestCutSUBRowsPaste()
 Dim sh As Worksheet, shDest As Worksheet, strSearch As String
 Dim i As Long, rngCut As Range, lastRowD As Long, lastRow As Long
 
 strSearch = "POS"
 Set sh = ActiveSheet
 Set shDest = Worksheets.aDD
 lastRow = sh.Range("A" & Rows.count).End(xlUp).row
 For i = 1 To lastRow
    If InStr(sh.Range("C" & i).Value, strSearch) > 0 Then
        lastRowD = shDest.Range("A" & Rows.count).End(xlUp).row
        sh.Rows(i).Cut shDest.Range("A" & lastRowD + 1)
    End If
 Next i
End Sub

How many such occurrences do you estimate to exist in your sheet to be processed? If a lot of them, I can adapt the code to use arrays and work fast enough for big ranges to be moved…

Edited:

The faster code variant, working in memory and dropping the processing result at once:

Sub TestCutSUBRowsPasteArrays()
 Dim sh As Worksheet, shDest As Worksheet, strSearch1 As String, strSearch2 As String
 Dim arr As Variant, arrCut As Variant, rngCut As Range, lastRow As Long, lastCol As Long
 Dim k As Long, i As Long, j As Long
 
 strSearch1 = "POS": strSearch2 = "Iyzico"
 Set sh = ActiveSheet
 Set shDest = Worksheets.Add
 lastRow = sh.Range("A" & Rows.Count).End(xlUp).Row
 'determine of the last (existing) column:
 lastCol = sh.Cells(1, Columns.Count).End(xlToLeft).Column
 'load all the range to be processed in an array:
 arr = sh.Range("A2", sh.Cells(lastRow, lastCol)).Value
 'initially redim the array at the total range dimesions
 ReDim arrCut(1 To lastCol, 1 To UBound(arr, 1))
 
 For i = 1 To UBound(arr)
    If InStr(arr(i, 3), strSearch1) > 0 Or _
                      InStr(arr(i, 3), strSearch2) > 0 Then
        'if one of the search string exists:
        k = k + 1 'increment the array row
        For j = 1 To lastCol
            arrCut(j, k) = arr(i, j) 'load the final array with cut elements
            arr(i, j) = "" 'eliminate the elements from initial array
        Next
    End If
 Next i
 'if no occurrences found, the code will exit:
 If k = 0 Then MsgBox "No occurrence foung in column C:C...": Exit Sub
 'Redim the array to the exact limit containing values:
 ReDim Preserve arrCut(1 To lastCol, 1 To k)
 'dropping the initial array (remained) values:
 sh.Range("A2", sh.Cells(lastRow, lastCol)).Value = arr
 'Dropping the processed array (arrCut) at once:
 shDest.Range("A2").Resize(UBound(arrCut, 2), _
        UBound(arrCut, 1)).Value = WorksheetFunction.Transpose(arrCut)
End Sub

22

solved If cell in column contains specific word then cut the row of the specific word [closed]