VBA for moving rows based on cell text

[Arty182925]

Hi all.

I have 2 columns of data. And I have plenty of workbooks to work with.

Anyway...

Column A has codes and Column B has links. Both of columns have headers.

I can do this with conditional formatting but it would take me alot of time like that.

What I need is this.

To write somewhere list of words, or in some cell or somewhere else.

I need to look to specific words in column B with links in it and move (not copy) that row (actually from column A and B) to another sheet named BLACK.

For example if I write list of words and one word is NEW, all rows that contain NEW in column B should be moved to another sheet(black)

That sheet also has same headers as first one.

And one more thing. When moving rows to another sheet, it shouldnt be empty rows after that.

Thanks

 

[HalfAce]

You didn't make clear (at least to me) if you want to search through column B for the words in your list one at a time, or if you want to search for all words in your list so here are a couple ideas.
If you just want to search for one word at a time (this wouldn't even require the list of words to be written...) you could use something like this.

Sub MoveUsingOneWord()
Dim SrchTerm As String, EndRw As Long, Rw As Long
EndRw = Cells(Rows.Count, "B").End(xlUp).Row
SrchTerm = InputBox("What term do you want to search for?")
For Rw = 2 To EndRw
  If InStr(Cells(Rw, "B").Value, SrchTerm) Then
    With Cells(Rw, "A").Resize(, 2)
      .Copy Sheets("Black").Cells(Rows.Count, "A").End(xlUp)(2)
      .Delete Shift:=xlUp
    End With
    Rw = Rw - 1
  End If
Next Rw
End Sub

If you would rather move all rows that contain any of the words in your list, all in one shot, then something like this should do.
(Note, you'll need to amend the code to your real range that holds the list of words to search column B for.)

Sub MoveUsingListOfWords()
Dim ListOfWords As Range, ListWord As Range, EndRw As Long, DltRng As Range
'''Amend the following range to the real range containing your list of words
Set ListOfWords = Range("J1:J" & Cells(Rows.Count, "J").End(xlUp).Row)
EndRw = Cells(Rows.Count, "B").End(xlUp).Row
For Each ListWord In ListOfWords
  For Each Rng In Range("B2:B" & EndRw)
    If InStr(Rng, ListWord) Then
      Rng.Offset(, -1).Resize(, 2).Copy Sheets("Black").Cells(Rows.Count, "A").End(xlUp)(2)
      If DltRng Is Nothing Then
        Set DltRng = Rng.Offset(, -1).Resize(, 2)
      Else
        Set DltRng = Union(DltRng, Rng.Offset(, -1).Resize(, 2))
      End If
    End If
  Next Rng
Next ListWord
If Not DltRng Is Nothing Then DltRng.Delete Shift:=xlUp
End Sub

Hope one or the other helps.

 

[Arty182925]

Hi HalfAce...

I can use both, but prefer second one so I dont need to write every word one by one. Sorry for not writing that before.

Anyway.

I am not sure if I am doing something wrong but, every time I tried to run, or first or second code I get "Subscript out of range"

Thanks so much for codes

 

[Arty182925]

Oh nvm, I got it right away lol.

I forgot to rename my sheet to Black.

It works awesome, thanks for this. You are great.

 

[Arty182925]

I just thought of something.

Can I add on second macro, to move rows that left after copying to Black (actually a and b column) to other sheet named white?

Thanks for helping

 

[HalfAce]

You are great.

Yeah, that's what I keep telling these fools I work with but so far nobody buys it.

Can I add on second macro, to move rows that left after copying to Black (actually a and b column) to other sheet named white?

Absolutely. Assuming you don't want to just rename the original sheet 'White' ... (because those rows are all that should be left on it after running the code...) you can simply add this line directly above the End Sub line:

Range("A2:B" & Cells(Rows.Count, "A").End(xlUp).Row).Cut Sheets("White").Cells(Rows.Count, "A").End(xlUp)(2)

Did I understand you correctly?

 

[Arty182925]

Yeah, you understand it right. It workes great.

Thanks.

Sorry for not answering before, I was busy alot.

P.S. Dont care about fools at work, they dont know what they talking about lol

 

[TryingBest]

Code:

Sub MoveUsingOneWord()
Dim SrchTerm As String, EndRw As Long, Rw As Long
EndRw = Cells(Rows.Count, "B").End(xlUp).Row
SrchTerm = InputBox("What term do you want to search for?")
For Rw = 2 To EndRw
  If InStr(Cells(Rw, "B").Value, SrchTerm) Then
    With Cells(Rw, "A").Resize(, 2)
      .Copy Sheets("Black").Cells(Rows.Count, "A").End(xlUp)(2)
      .Delete Shift:=xlUp
    End With
    Rw = Rw - 1
  End If
Next Rw
End Sub

Hi .. What if I want to cut/paste the row data onto the same sheet?
I tried with the below statement, but that creates a loop and doesn't seem to work.

".Copy Cells(Rows.Count, "A").End(xlUp)(2)"