如果列中的单元格包含特定单词，则剪切特定单词的行

Question

我想要一个vba在E列中搜索“ POS”一词，然后剪切“ POS”中的行，并将其粘贴到另一个工作表中。

这是我尝试的代码。但是，它仅剪切第一行POS。如果您能帮助我，我将非常高兴。

enter image description here

    Dim I As Long
   For I = ActiveSheet.UsedRange.Rows.Count To 2 Step -1
        If CStr(Cells(I, "E").Value) = "POS" Then
             Rows(I).EntireRow.Cut
             
 Sheets.Add After:=ActiveSheet
    Range("A2").Select
    ActiveSheet.Paste
    
        End If
    Next I
End Sub

Answer 1

请尝试下一个代码（适合在C：C中搜索字符串出现的位置）：

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

您估计要处理的工作表中存在多少次此类事件？如果它们很多，我可以修改代码以使用数组，并以足够快的速度工作以移动大范围...

编辑：

更快的代码变体，它在内存中工作并立即删除处理结果：

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