Cut row to new sheet if text is found within multiple columns

Mike___

New Member
Joined
Jul 18, 2019
Messages
12
Hi all,

I currently use conditional formatting for this task - but I am finding myself needing to do this more often so wished to set up a VBA rather than use a long winded work around. In the past I have successfully created VBA's by mixing and matching various codes. Sadly - I am unable to find a solution to this and I know it is a pretty easy one which I am finding annoying.

I am looking to search columns C to K for text (normally it is just a partial match I am after). And if found the entire row is cut and moved to sheet2. There will be some blank cells in the columns and the documents could contain 20 - 40k rows of data.

The below code works on a search for just column W but I was unable to add multiple columns to the code - Sorry. I believe the answers are contained in this link [FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]https://www.mrexcel.com/forum/excel-questions/855173-vba-lastrow.html but my attempts of adding to this code myself have failed.[/FONT]

The search term that I will be using will constantly change (in this instance Business*) - Although I could just change it each time in the VBA - in a perfect world I would like to add the word or partial word to be found in a box when the VBA is run to speed up the process.

If anyone could help I would be most grateful.

Thanks
Mike

Option Explicit
Sub Test()

Dim sht1 As Worksheet, sht2 As Worksheet
Dim i As Long

Set sht1 = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = ThisWorkbook.Worksheets("Sheet2")

For i = 2 To sht1.Cells(sht1.Rows.Count, "w").End(xlUp).Row
If sht1.Range("w" & i).Value Like "Business*" Then
sht1.Range("A" & i).EntireRow.Cut sht2.Range("A" & sht2.Cells(sht2.Rows.Count, "w").End(xlUp).Row + 1)
End If
Next i

End Sub
 
I found out the problem.

The data in columns AE:AM contains various keywords but after the majority of them it contains a semi colon and a number eg Science;13 or Team Building;9.

When I tested your code with the semi colon and number removed it worked. As soon as I added it back it didn't.

I looked to attach a sample doc for you to test but I do not have the appropriate permissions. Apologies.
 
Upvote 0

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
I looked to attach a sample doc for you to test but I do not have the appropriate permissions. Apologies.
It isn't a matter of permissions as the forum does not allow attachments. However, you can post small screen shots of your worksheet(s). Follow the 'Look here' link in my signature block below to find out how.
 
Upvote 0
KeywordKeyword 2Keyword 3Keyword 4Keyword 5Keyword 6Keyword 7Keyword 8Keyword 9
Biomedical research;1Medical genetics;1R scripting;1Unix scripting;1NGS-tools;2Next-generation sequencing;2Bioinformatics;3Genomics;3Molecular Diagnostics;9
Cell Culture;1Chromatography;1HPLC;1Lifesciences;1Biotechnology;2GLP;3PCR;3Molecular Biology;7Microbiology;9
DNA electrophoresis;3DNA sequencing;3PCR primer design;3DNA extraction;4Genotyping;4PCR;4Sequencing;4Western Blotting;5Genomics;6
Diagnostics;2Life Sciences;2qPCR;2Biotechnology;3Cell Culture;3Research;3Genetics;4Biochemistry;5Molecular Biology;5
Biotechnology;1Cell Culture;1Clinical Research;1Immunoassays;1Infectious Diseases;1Lifesciences;1Microbiology;1Molecular Biology;1PCR;1
Infectious Diseases;4Medical Devices;5Sequencing;7Pharmaceutical Industry;8qPCR;9Genomics;14Lifesciences;14Biotechnology;35Molecular Biology;45
Biochemistry;1Durum Wheat;1MicroRNA Profiling;1Molecular Biology;1Next-generation Sequencing;1Plant Physiology;1Scientific Writing;1
DNA sequencing;1Epigenetics;1Lifesciences;1Prostate Cancer;1qPCR;2Genomics;5Research;7Genetics;16Molecular Biology;19
CMV;1HPV;1Herpes;1Instagram;1NCBI;1iPhone;1iPhoto;1Multiplex PCR;3PCR;9
Genomics;1Lifesciences;1Lecturing;3Proteomics;4RT-PCR;5Clinical Research;7PCR;8Molecular Biology;15Cell Culture;21
Blood Bank;1Hormones;1Nanoparticles;1PLGA;1Serology;1Laboratory Skills;3Biochemistry;4Microbiology;4Laboratory Medicine;12
Agriculture;1Biotechnology;1GMP;1Lifesciences;1Molecular Biology;1PCR;1R&D;1Six Sigma;1Validation;1
qPCR;13Flow Cytometry;16PCR;27Cell Biology;46Biochemistry;48Molecular Cloning;56Cell Culture;59Western Blotting;74Molecular Biology;93

<colgroup><col width="72" span="9" style="width:54pt"> </colgroup><tbody>
</tbody>
 
Upvote 0
Thanks for the sample data.
:oops: Oops, big mistake on my part, sorry about that. I had two arguments in the Instr function the wrong way around. It should be
Rich (BB code):
If InStr(1, a(i, j), strToFind, 1) > 0 Then
 
Upvote 0
Thanks for your help with this - it now copies across perfectly.

There is one last remaining issue that doesn't quite work as requested. Each time I run a new search it wipes over what has previously been found rather than adding to the sheet 2 results.

Apologies for taking up your time on this - but it is much appreciated.
 
Upvote 0
I had assumed that we could tell the last row used in Sheet2 by looking for the bottom of column A. Apparently that is not the case. Try changing this line.

Rich (BB code):
With ws2
  lr = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlValues, SearchOrder:=xlByRows, _
          SearchDirection:=xlPrevious, SearchFormat:=False).Row
End With
 
Upvote 0
Assuming you specify the unique beginning text, at minimum, for the keyword you want to search for (for example, "Cell C" for "Cell Culture" would be sufficient although you can type more letters of the keyword if you wish), then does this macro work for you...
Code:
[table="width: 500"]
[tr]
	[td]Sub Copy_Rows_v2()
  Dim LastRow1 As Long, LastRow2 As Long, strToFind As String
  LastRow1 = Sheets("[B][COLOR="#0000FF"]Sheet1[/COLOR][/B]").Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
  LastRow2 = Sheets("[B][COLOR="#FF0000"]Sheet2[/COLOR][/B]").Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
  strToFind = InputBox("Enter Keyword to be found")
  With Sheets("[B][COLOR="#0000FF"]Sheet1[/COLOR][/B]").Range("AN2:AN" & LastRow1)
    .Formula = "=MATCH(""" & strToFind & "*"",[B][COLOR="#0000FF"]Sheet1[/COLOR][/B]!AE2:AM2,0)"
    On Error Resume Next
    Intersect(Sheets("[B][COLOR="#0000FF"]Sheet1[/COLOR][/B]").Columns("AE:AM"), .SpecialCells(xlFormulas, xlNumbers).EntireRow).Copy Sheets("[B][COLOR="#FF0000"]Sheet2[/COLOR][/B]").Cells(LastRow2 + 1, "A")
    On Error GoTo 0
  End With
  Sheets("[B][COLOR="#0000FF"]Sheet1[/COLOR][/B]").Columns("AN").Clear
End Sub[/td]
[/tr]
[/table]
 
Last edited:
Upvote 0
Hi Rick,

This copies across the results to columns A to I in sheet 2 rather than to AE to AM.
I need the entire row copied across if keyword is found as there is data in the other columns that needs to move across too.
 
Upvote 0
Hmmm I am afraid we are back to nothing copying across again?
The only effect of the change in post 16 is to determine what row to paste the data in Sheet2, not what is copied.

Are you sure that you still have the changed line from post 14 & didn't revert to the old version of that code line?
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,526
Messages
6,114,136
Members
448,551
Latest member
Sienna de Souza

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top