时间戳

首页 > 解决方案 > 如果列中的单元格包含特定单词，则剪切特定单词的行

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

问题描述

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

在此处输入图像描述

这是我尝试过的代码。但是，它只削减了第一个 POS 行。如果你能帮助我，我会非常高兴。

在此处输入图像描述

    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

标签： excelvba

解决方案

请尝试下一个代码（适用于在 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

推荐阅读