I am searching a column for cell that contains text and does not contain the word “cat” in the first 6 characters (needs to be case insensitive). This will then cut that entire row to another sheet. Cannot get the code to run without compile errors. the below code is before i try to change it. I do not know how to code it to look at the first 6 characters.
tried instr & iserror but i think my existing code just needs a small alteration which escapes me.
Sub CATDEFECTS() UsdRws = Range("C" & Rows.Count).End(xlUp).Row For i = UsdRws To 2 Step -1 If Range("C" & i).Value Like "<>""" And Range("c" & i).Value Like "CAT" Then Rows(i).Cut Sheets("AWP DEFECTS").Range("A" & rows.Count).End(xlUp).Offset(1) Rows(i).Delete End If Next i End Sub
Regardless of how you decide to implement the macro, your test to see if a cell is blank is entirely redundant. You can just test if the cell meets your
CAT criteria. If it does, it is definitely not blank so no need to test it.
You can look at the first 6 characters with
If Left(Range("C" & i), 6) Like "*CAT*" Then
Option Compare to work (Thanks @Comintern)
I would prefer this method. Its explicit and does not delete or shift anything inside the loop so your action statements are greatly minimized.
Sub Cat() Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") '<--UPDATE Dim ps As Worksheet: Set ps = ThisWorkbook.Sheets("AWP DEFECTS") Dim LR As Long, DeleteMe As Range, i As Long LR = ws.Range("C" & ws.Rows.Count).End(xlUp).Row For i = 2 To LR If InStr(Left(ws.Range("C" & i), 6), "CAT") Then If Not DeleteMe Is Nothing Then Set DeleteMe = Union(DeleteMe, ws.Range("C" & i)) Else Set DeleteMe = ws.Range("C" & i) End If End If Next i Application.ScreenUpdating = False If Not DeleteMe Is Nothing Then LR = ps.Range("A" & ps.Rows.Count).End(xlUp).Row DeleteMe.EntireRow.Copy ps.Range("A" & LR) DeleteMe.EntireRow.Delete End If Application.ScreenUpdating = True End Sub
If cat is within the first 6 characters then InStr will report its position being less than 5.
Sub CATDEFECTS() dim UsdRws as long, pos as long UsdRws = Range("C" & Rows.Count).End(xlUp).Row For i = UsdRws To 2 Step -1 pos =instr(1, cells(i, "C").value2, "cat", vbtextcompare) If pos > 0 and pos < 5 Then Rows(i).Cut Sheets("AWP DEFECTS").Range("A" & rows.Count).End(xlUp).Offset(1) Rows(i).Delete End If Next i End Sub
Criteria Backup (Hide/Delete)
To enable the deletion of the rows in the Source Worksheet you have to set
True in the constants section. Adjust the other constants to fit you needs.
Option Explicit 'Option Compare Text Sub CATDEFECTS() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With On Error GoTo ProcedureExit ' Source Constants Const cSource As Variant = "Sheet1" ' Worksheet Name/Index Const cCol As Variant = "C" ' Search Column Letter/Number Const cFirstR As Long = 2 ' First Row Number Const cChars As Long = 6 ' Number of Chars Const cSearch As String = "CAT" ' Search String ' Target Constants Const cTarget As Variant = "AWP DEFECTS" ' Worksheet Name/Index Const cColTgt As Variant = "A" ' Column Letter/Number Const cFirstRTgt As Long = 2 ' First Row Number Const cDEL As Boolean = False ' Enable Delete (True) ' Variables Dim rngH As Range ' Help Range Dim rngU As Range ' Union Range Dim vntS As Variant ' Source Array Dim i As Long ' Source Range Row Counter ' The Criteria ' When the first "cChars" characters do not contain the case-INsensitive ' string "cSearch", the criteria is met. ' Source Worksheet With ThisWorkbook.Worksheets(cSource) ' Calculate Last Cell in Search Column using the Find method and ' assign it to Help (Cell) Range. Set rngH = .Columns(cCol).Find("*", , xlFormulas, _ xlWhole, xlByColumns, xlPrevious) ' Calculate Source Column Range from Help (Cell) Range. If Not rngH Is Nothing Then ' Last Cell was found. ' Calculate Source Column Range and assign it to ' Help (Column) Range using the Resize method. Set rngH = .Cells(cFirstR, cCol).Resize(rngH.Row - cFirstR + 1) ' Copy Help (Column) Range into 2D 1-based 1-column Source Array. vntS = rngH ' Show hidden rows to prevent the resulting rows (the rows to be ' hidden or deleted) to appear hidden in Target Worksheet. rngH.EntireRow.Hidden = False Else ' Last Cell was NOT found (unlikely). MsgBox "Empty Column '" & cCol & "'." GoTo ProcedureExit End If ' Loop through rows of Source Array. For i = 1 To UBound(vntS) ' Check if current Source Array value doesn't meet Criteria. If InStr(1, Left(vntS(i, 1), cChars), cSearch, vbTextCompare) = 0 _ Then ' "vbUseCompareOption" if "Option Compare Text" ' Note: To use the Like operator instead of the InStr function ' you have to use (uncomment) "Option Compare Text" at the beginning ' of the module for a case-INsensitive search and then outcomment ' the previous and uncomment the following line. ' If Not Left(vntS(i, 1), cChars) Like "*" & cSearch & "*" Then Set rngH = .Cells(i + cFirstR - 1, cCol) If Not rngU Is Nothing Then ' Union Range contains at least one range. Set rngU = Union(rngU, rngH) Else ' Union Range does NOT contain a range (only first time). Set rngU = rngH End If End If Next End With ' Target Worksheet If Not rngU Is Nothing Then ' Union Range contains at least one range. With ThisWorkbook.Worksheets(cTarget) ' Calculate Last Cell in Search Column using the Find method and ' assign it to Help Range. Set rngH = .Columns(cColTgt).Find("*", , xlFormulas, _ xlWhole, xlByColumns, xlPrevious) ' Calculate Last Cell from Help Range, but in column 1 ("A"). If Not rngH Is Nothing Then ' Last Cell was found. Set rngH = .Cells(rngH.Row + 1, 1) Else ' Last Cell was NOT found. Set rngH = .Cells(cFirstRTgt - 1, 1) End If ' Copy the entire Union Range to Target Worksheet starting from ' Help Range Row + 1 i.e. the first empty row (in one go). ' Note that you cannot Cut/Paste on multiple selections. rngU.EntireRow.Copy rngH End With ' Hide or delete the transferred rows (in one go). If cDEL Then ' Set the constant cDEL to True to enable Delete. rngU.EntireRow.Delete Else ' While testing the code it is better to use Hidden. rngU.EntireRow.Hidden = True End If End If ProcedureExit: With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End Sub
- The use of the array did not speed up considerably.
InStrfunction was a few milliseconds faster than the
Likeoperator in my data set.
- Calculating the Real Used Range and copying it into a Source Array
and then writing the data that meets the criteria from Source Array
to a Target Array and copying the Target Array to the Target
Worksheet, might be faster, and/but would additionally copy the data without formulas or formatting.