Yet Another Find, Cut, Paste Scenario

[RJP3030]

Hello Everyone, I am in need of some help please. I have tried adapting some of the code alreadt posted here, but I am a novice and cannot get this part to work.

I have 1 workbook per day (Mon-Fri) containing deposit info. The 1st sheet contains data, and column H is labeled Text.

I need vba code to search entire Text column (H) for 4 different strings, and whenever finds any one of the 4, to cut that entire row and paste into next empty row in Sheet 2. I need it to go through entire worksheet and move all occurrences.

Strings: San Fransisco, New York 17003, HoustonMCC,
Washington Government.

Let me know if more info needed.

Thanks so much for your help!

 

[Jaye7]

I have used some script to find your data, however I can't work out how to paste it as whatever I try it locks up, if anyone could finish the script off.

Sub Paste_Data()
 
  Dim Cell As Range
  Dim LastCol As Long
  Dim Lastrow As Long
  Dim RE As Object
  Dim Rng As Range
  Dim S As String
  Dim wsSource As Worksheet, wsDest As Worksheet
 
    Set wsSource = Sheets("Sheet1") ' Source worksheet
    Set wsDest = Sheets("Sheet2")   ' Destination worksheet
 
    LastCol = wsSource.Cells.find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
    Lastrow = wsSource.Cells.find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
    Set Rng = wsSource.Range("A1", Cells(Lastrow, LastCol))
 
    Set RE = CreateObject("VBScript.RegExp")
    RE.IgnoreCase = True
    RE.Pattern = "(San Fransisco)|(New York 17003)|(HoustonMCC)|(Washington Government)"
    ', , ,
'
      For R = Lastrow To 1 Step -1
        For Each Cell In Rng.Rows(R).Cells
          S = S & " " & Cell.Text
 
 
 
 
        Next Cell
 
        If RE.Test(S) = True Then wsSource.Rows(Rng.Rows(R).Row).Copy
 
'************************************       
        ' script needed here to paste data.
 
'************************************
 
        S = ""
      Next R
 
    Set RE = Nothing
 
End Sub

 

[RJP3030]

Thanks Jaye this is very helpful. I will work with it and see if I can figure out paste.

Thanks!

 

[Jaye7]

This is not a great way to do it as it is case sensitive, however since no-one else is offering a better way you could use it.

It's basically just a filter which copies the data across to the next sheet.

Sub Macro1()
 
    Sheets("Sheet1").Select
    Cells.Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$C$8").AutoFilter Field:=1, Criteria1:=Array( _
        "HoustonMCC", "New York 17003", "San Francisco", "Washington Government"), _
        Operator:=xlFilterValues
    Cells.Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A1").Select
    ActiveSheet.Paste
    Range("A1").Select
    Sheets("Sheet1").Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    Range("A1").Select
End Sub

 

[Jaye7]

I posted a similar thread to your thread to try and get someone to help me and P.Holko provided the perfect script which is located below.

http://www.mrexcel.com/forum/showthread.php?p=2847207&posted=1#post2847207

I changed the values to your specified values and it works great.

You can add additional values/ arrays also, which is great.

Sub CopyEntireRow()
Dim CellR As Range
Dim strName As String
ReDim arr(4) As String
arr(1) = "San Fransisco"
arr(2) = "HoustonMCC"
arr(3) = "Washington Government"
arr(4) = "New York 17003"
For i = 1 To 4
    strName = arr(i)
    
    For Each CellR In Worksheets("Sheet1").UsedRange
        If InStrRev(CellR.Value, strName, -1, vbTextCompare) <> 0 Then
            If WorksheetFunction.CountA(Worksheets("Sheet2").Cells) = 0 Then
                LastRow = 1
            Else
                LastRow = Sheets("Sheet2").Cells.Find(What:="*", After:=[A1], SearchDirection:=xlPrevious).Row + 1
            End If
            Sheets("Sheet2").Rows(LastRow & ":" & LastRow).Value = CellR.EntireRow.Value
        
        End If
    
    Next
    
Next i
End Sub

 

[RJP3030]

Haha I saw that yesterday.

Just tried it out, and it works perfectly. Thanks so much, you really went out of your way. Good karma for you!

Best wishes