Conditional copy entire rows if cell value meets criteria - Excel VBA

[CakzPrimz]

Dear MrExcel,

In sheets "Data" I want to copy entire row only if cell value in column F, contents these string arrays, regardless the words in Upper case, Proper case or Lower case).

- Cement, it could be Type 5 cement, Cements, etc
- Spun
- Concrete

Copying entire rows into sheets "Collector" starting in row number 3.

Thank so much.
prima

 

[My Aswer Is This]

Are you saying the value must have Cement?

Like sally likes cement
Or
My cement is dry
Or

Is your cement hard

Or the cement's content is weak

And if that is true then:

Concrete

would not apply
​

 

[CakzPrimz]

All sentences that content one of these three words, "cement", "spun", "concrete"
example:
- my cement is dry
- spun pile

Thank so much.
prima

 

[My Aswer Is This]

I will have to leave this question for someone else to answer.
Using 3 possible values and saying it may say with some value before and after is beyond my Knowledgebase.

I'm sure someone else here on this forum will have a answer

 

[CakzPrimz]

I will have to leave this question for someone else to answer.
Using 3 possible values and saying it may say with some value before and after is beyond my Knowledgebase.

I'm sure someone else here on this forum will have a answer

Thanks so much anyway.

 

[My Aswer Is This]

I finally worked out a answer:
Try this:
Run this script from the sheet with all your data.
Will copy rows to sheet named Collector

Sub Filter_Me_Using_Array_With_Wildcard()
'Modified  10/2/2018  4:50:17 AM  EDT
Dim Lastrow As Long
Dim Lastrowa As Long
Dim c As Long
Dim Counter As Long
c = 6 ' Column Number Modify this to your need
Lastrow = Cells(Rows.Count, c).End(xlUp).Row
Dim Del As Variant
Del = Array("cement", "spun", "concrete")
ans = UBound(Del)
    For i = 1 To ans + 1
        Lastrowa = Sheets("Collector").Cells(Rows.Count, c).End(xlUp).Row + 1
            If Lastrowa < 3 Then Lastrowa = 3
    
        With ActiveSheet.Cells(1, c).Resize(Lastrow)
            .AutoFilter 1, "*" & Del(i - 1) & "*"
            Counter = .Columns(c).SpecialCells(xlCellTypeVisible).Count
            If Counter > 1 Then
                .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets("Collector").Rows(Lastrowa)
            Else
                MsgBox "No values found"
            End If
                .AutoFilter
        End With
    Next
    MsgBox "Done"
End Sub

 

[Peter_SSs]

Another option to consider. My code
- assumes 'Data' has a heading row in row 1.
- assumes that sheet 'Collector' contains nothing from row 3 down. That's just how I interpreted your comment "Copying entire rows into sheets "Collector" starting in row number 3". If there could be data below that and you want this new data below that, a modification can be made.
- copies all the rows at once so the original row order is maintained.
- can be run with either sheet active.

Sub Move_Rows()
  Dim lc As Long
  Dim rCrit As Range
  
  With Sheets("Data")
    lc = .Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    Set rCrit = .Cells(1, lc + 2).Resize(2)
    rCrit.Cells(2).Formula = "=COUNT(SEARCH({""cement"",""spun"",""concrete""},F2))"
    .UsedRange.Resize(, lc).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rCrit, CopyToRange:=Sheets("Collector").Range("A3"), Unique:=False
    Sheets("Collector").Rows(3).Delete
    rCrit.ClearContents
  End With
End Sub

Just one other point to note: I don't know if it is possible with your data, but if a cell in column F of 'Data' contains two (or more) of the strings being searched for (eg "The concrete contains cement") then the code from post 6 will copy that row twice (or more) to the 'Collector' sheet.

 

[YantiPrima]

Dear My Answer Is This,

It works, with note:

- if the data to copy (sheet "Data") start in row # 2 it is running well except it copies also images in the range
- if the data to copy (sheet "Data") start in row # 3 while row 1 & 2 is blank, it will copy also the blank row # 1, # 2 (repeated copy)

Thank so much for your help and attention.

Problem 98% solved !

prima

 

[My Aswer Is This]

One answer is:
You said in your original post:

Copying entire rows into sheets "Collector" starting in row number 3.
That's why the pasting starts in Row 3

So did you want the copying to start in row 3 or the pasting to start in row 3?




Thank so much.​

 

[YantiPrima]

Another option to consider. My code
- assumes 'Data' has a heading row in row 1.
- assumes that sheet 'Collector' contains nothing from row 3 down. That's just how I interpreted your comment "Copying entire rows into sheets "Collector" starting in row number 3". If there could be data below that and you want this new data below that, a modification can be made.
- copies all the rows at once so the original row order is maintained.
- can be run with either sheet active.

Sub Move_Rows()
  Dim lc As Long
  Dim rCrit As Range
  
  With Sheets("Data")
    lc = .Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    Set rCrit = .Cells(1, lc + 2).Resize(2)
    rCrit.Cells(2).Formula = "=COUNT(SEARCH({""cement"",""spun"",""concrete""},F2))"
    .UsedRange.Resize(, lc).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rCrit, CopyToRange:=Sheets("Collector").Range("A3"), Unique:=False
    Sheets("Collector").Rows(3).Delete
    rCrit.ClearContents
  End With
End Sub

Just one other point to note: I don't know if it is possible with your data, but if a cell in column F of 'Data' contains two (or more) of the strings being searched for (eg "The concrete contains cement") then the code from post 6 will copy that row twice (or more) to the 'Collector' sheet.

Dear Peter,

I have tried to apply your code, but no record to copy at all to "Collector" sheet.
And I do not know the reason why.

Really appreciate for help and kind attention

Thank you
prima