Find text in 2 columns, copy row to new sheet

3

3gswish

New Member
Joined
Apr 28, 2011
Messages
29
Hi Everybody,

Thanks in advance for your help - I am very new to VBA and am struggling with what should be a very easy problem. I am very grateful for any advice and code you can provide. I am finding lots of script examples but when I try to mod them for my specific use case, they fail. After many many hours I am fried. I am using Win7/Excel2010.

Here is what I am trying to do:
Sheet1 contains hundreds of rows. ColumnA and ColumnE contain the string I am looking for. That string may exist in other columns as well, but I need to focus the search on just Columns A,E. The string may be by itself or within a much longer string.

If a row contains that string in Either Column A or E (an and/or operation) then I want to copy that row to the next blank row in Sheet2 once.
The icing on the cake would be to also add an additional column to sheet2 that contains the original row number from sheet1.

The most success I have had so far is with this code that prompts for the text, but I end up with more rows that I started with. When the string exists in both Column A and E, the row get's copied twice.

Would you please be so kind as to suggest how to limit the search range to just columns A,E, copy the row only once, and how I might add a column with the original row#?

Thank you very much.
3gswish

Sub Button98_Click() 'Search with highlight

Highlight "Report Sheet"
End Sub


Sub Highlight(sSheet As String)
Dim cl As Range, rng As Range
Dim sFind As String, FirstAddress As String
Dim sht As Worksheet

Set rng = ActiveSheet.UsedRange
Set sht = ActiveWorkbook.Sheets.Add(Before:=Worksheets(Worksheets.Count))
sht.Name = sSheet

sFind = Application.InputBox("Enter search string")
With rng
Set cl = .Find(sFind, LookIn:=xlValues)
If Not cl Is Nothing Then
FirstAddress = cl.Address
Do
'cl.EntireRow.Interior.ColorIndex = 48
If sht.Range("A65536").End(xlUp).Value = "" Then
cl.EntireRow.Copy sht.Range("A65536").End(xlUp)
Else
cl.EntireRow.Copy sht.Range("A65536").End(xlUp).Offset(1, 0)
End If
Set cl = .FindNext(cl)
Loop While Not cl Is Nothing And cl.Address <> FirstAddress
End If
End With
End Sub
 

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"
Sort by date Sort by votes
Code: 
Sub Highlight(sSheet As String)

    Dim cl As Range, rng As Range
    Dim sFind As String, FirstAddress As String
    Dim sht As Worksheet
    Dim c As Long, r As Long
    
    Set rng = ActiveSheet.Range("A:A, E:E")                                         ' Search range
    On Error Resume Next
    c = ActiveSheet.Cells.Find("*", , , , xlByColumns, xlPrevious).Column + 1       ' Next empty column
    On Error GoTo 0
    If c = 0 Then
        MsgBox "The active sheet is blank."
        Exit Sub
    End If
    
    sFind = Application.InputBox("Enter search string")                             ' Prompt for search string
    If sFind = "False" Or sFind = vbNullString Then Exit Sub                        ' User canceled on prompt
    
    Set cl = rng.Find(sFind, , xlValues, xlPart, xlByRows, xlNext, False)           ' Find the 1st match if any
    If Not cl Is Nothing Then                                                       ' Test if a 1st match was found
        
        Set sht = ActiveWorkbook.Sheets.Add(Before:=Worksheets(Worksheets.Count))   ' Create new sheet to paste to
        Do
            r = r + 1                                                               ' Counter to enumerate sheet names if needed
            On Error Resume Next
            If r = 1 Then sht.Name = sSheet Else sht.Name = sSheet & " (" & r & ")" ' Name new worksheet. Ignore error if sheet name already exist.
            On Error GoTo 0
        Loop Until InStr(sht.Name, sSheet)
        r = 0
        
        Application.ScreenUpdating = False
        FirstAddress = cl.Address                                                   ' Store address of 1st match to halt loop

        Do
            'cl.EntireRow.Interior.ColorIndex = 48
            If WorksheetFunction.CountIf(sht.Columns(c), cl.Row) = 0 Then           ' Test if row was already copied (check recorded row numbers in last column)
                r = r + 1                                                           ' Next empty row counter
                cl.EntireRow.Copy sht.Range("A" & r)                                ' Copy-Paste matched row
                sht.Cells(r, c) = cl.Row                                            ' Row number of copied row in last column
            End If
            
            Set cl = rng.FindNext(cl)                                               ' Find the next match
            
        Loop While Not cl Is Nothing And cl.Address <> FirstAddress
        Application.ScreenUpdating = True
        
    Else
        MsgBox "No match found for " & sFind, vbCritical, "No Match Found"          ' No 1st match found.
    End If
    
End Sub
 
Last edited:
Upvote 0
Thanks Alpha Frog - much better!

The only hitch is that the output rows are in order of string found in ColumnA then ColumnE. So data in the form of:

A ... E
1 x string
2 x string
3 string string
4 string x
5 x x
6 string x

is sorted in the output sheet as:

A ... E ... L
1 string string 3
2 string x 4
3 string x 6
4 x string 1
5 x string 2


I tried to add some sort functionality to the end of the script by recording a macro, pasting the code before the <end sub> tag, but even that didn't work (weird...). Other code from the web didn't work either.

Columns("A:L").Select
ActiveWorkbook.Worksheets("Results").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Results").Sort.SortFields.Add Key:=Range("L1:L273" _
), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Results").Sort
.SetRange Range("A1:L273")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select


I can certainly do a manual sort, but it sure would be nice to have it sorted by the row ID column that is added.

Any suggestions?

Thanks everybody!
 
Upvote 0
Code: 
Sub Highlight(sSheet As String)

    Dim cl As Range, rng As Range
    Dim sFind As String, FirstAddress As String
    Dim sht As Worksheet
    Dim c As Long, r As Long
    
    Set rng = ActiveSheet.Range("A:A, E:E")                                         ' Search range
    On Error Resume Next
    c = ActiveSheet.Cells.Find("*", , , , xlByColumns, xlPrevious).column + 1       ' Next empty column
    On Error GoTo 0
    If c = 0 Then
        MsgBox "The active sheet is blank."
        Exit Sub
    End If
    
    sFind = Application.InputBox("Enter search string")                             ' Prompt for search string
    If sFind = "False" Or sFind = vbNullString Then Exit Sub                        ' User canceled on prompt
    
    Set cl = rng.Find(sFind, , xlValues, xlPart, xlByRows, xlNext, False)           ' Find the 1st match if any
    If Not cl Is Nothing Then                                                       ' Test if a 1st match was found
        
        Set sht = ActiveWorkbook.Sheets.Add(Before:=Worksheets(Worksheets.Count))   ' Create new sheet to paste to
        Do
            r = r + 1                                                               ' Counter to enumerate sheet names if needed
            On Error Resume Next
            If r = 1 Then sht.Name = sSheet Else sht.Name = sSheet & " (" & r & ")" ' Name new worksheet. Ignore error if sheet name already exist.
            On Error GoTo 0
        Loop Until InStr(sht.Name, sSheet)
        r = 0
        
        Application.ScreenUpdating = False
        FirstAddress = cl.Address                                                   ' Store address of 1st match to halt loop

        Do
            'cl.EntireRow.Interior.ColorIndex = 48
            If WorksheetFunction.CountIf(sht.Columns(c), cl.Row) = 0 Then           ' Test if row was already copied (check recorded row numbers in last column)
                r = r + 1                                                           ' Next empty row counter
                cl.EntireRow.Copy sht.Range("A" & r)                                ' Copy-Paste matched row
                sht.Cells(r, c) = cl.Row                                            ' Row number of copied row in last column
            End If
            
            Set cl = rng.FindNext(cl)                                               ' Find the next match
            
        Loop While Not cl Is Nothing And cl.Address <> FirstAddress
        
        [COLOR="Green"]' Sort rows[/COLOR]
[COLOR="Red"]        sht.UsedRange.Sort Key1:=Cells(1, c), _
                           Order1:=xlAscending, _
                           Header:=xlGuess[/COLOR]
        
        Application.ScreenUpdating = True
    Else
        MsgBox "No match found for " & sFind, vbCritical, "No Match Found"          ' No 1st match found.
    End If
    
End Sub
 
Upvote 0
AWESOME! Thanks AlphaFrog. Can you please recommend a good resource for more studying?

Best,

3gswish
 
Upvote 0
Ok, thanks anyway. Modded the script a bit to prompt the user and adjust the range as needed.

Sub Find_and_Move() 'Search and Move
Highlight "Results"
End Sub
Sub Highlight(sSheet As String)

Dim cl As Range, rng As Range
Dim sFind As String, FirstAddress As String
Dim sht As Worksheet
Dim c As Long, r As Long

sFind = Application.InputBox("Include Sentences? (y|n)")
If sFind = "N" Or sFind = "n" Then Set rng = ActiveSheet.Range("A:A") ' Search Terms only
If sFind = "Y" Or sFind = "y" Then Set rng = ActiveSheet.Range("A:A, E:E") ' Search Terms and Sentences
If sFind = "False" Or sFind = vbNullString Then Exit Sub


' Set rng = ActiveSheet.Range("A:A, E:E")
On Error Resume Next
c = ActiveSheet.Cells.Find("*", , , , xlByColumns, xlPrevious).Column + 1 ' Next empty column
On Error GoTo 0
If c = 0 Then
MsgBox "The active sheet is blank."
Exit Sub
End If

sFind = Application.InputBox("Enter search string") ' Prompt for search string
If sFind = "False" Or sFind = vbNullString Then Exit Sub ' User canceled on prompt

Set cl = rng.Find(sFind, , xlValues, xlPart, xlByRows, xlNext, False) ' Find the 1st match if any
If Not cl Is Nothing Then ' Test if a 1st match was found

Set sht = ActiveWorkbook.Sheets.Add(Before:=Worksheets(Worksheets.Count)) ' Create new sheet to paste to
Do
r = r + 1 ' Counter to enumerate sheet names if needed
On Error Resume Next
If r = 1 Then sht.Name = sSheet Else sht.Name = sSheet & " (" & r & ")" ' Name new worksheet. Ignore error if sheet name already exist.
On Error GoTo 0
Loop Until InStr(sht.Name, sSheet)
r = 0

Application.ScreenUpdating = False
FirstAddress = cl.Address ' Store address of 1st match to halt loop

Do
'cl.EntireRow.Interior.ColorIndex = 48
If WorksheetFunction.CountIf(sht.Columns(c), cl.Row) = 0 Then ' Test if row was already copied (check recorded row numbers in last column)
r = r + 1 ' Next empty row counter
cl.EntireRow.Copy sht.Range("A" & r) ' Copy-Paste matched row
sht.Cells(r, c) = cl.Row ' Row number of copied row in last column
End If

Set cl = rng.FindNext(cl) ' Find the next match

Loop While Not cl Is Nothing And cl.Address <> FirstAddress
Application.ScreenUpdating = True

' Sort rows
sht.UsedRange.Sort Key1:=Cells(1, c), _
Order1:=xlAscending, _
Header:=xlGuess

Application.ScreenUpdating = True
Else
MsgBox "No match found for " & sFind, vbCritical, "No Match Found" ' No 1st match found.
End If


End Sub
 
Upvote 0
Another method...
Code: 
If MsgBox("Include sentences?", vbQuestion + vbYesNo, "Search Range") = vbYes Then
    Set rng = ActiveSheet.Range("A:A, E:E") ' Search Terms and Sentences
Else
    Set rng = ActiveSheet.Range("A:A") ' Search Terms only
End If


Forum Tip:
It would be best if you surround your VBA code with code tags e.g.; [CODE]your VBA code here[/CODE]
It makes reading your VBA code much easier. When you're in the forum editor, highlight your pasted VBA code and then click on the icon with the pound or number sign #.
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question Question
Using pattern searches with a variable to find the correct values
2
Replies
10
Views
262
chazrab
C
J
  • Solved
Copy /past cells by inputbox on sheet 2 to sheet1 using VBA
2
Replies
12
Views
616
DanteAmor
DanteAmor
C
  • Question Question
How would i use the FIND method with the AND operator to find any two words in a sheet cell, i.e., "understanding" AND "heart"
2
Replies
11
Views
553
Trebor76
T
S
  • Question Question
Copy/paste special values of Excel table based on cell value
Replies
2
Views
314
stacey_t
S
A
  • Question Question
VBA Highlight cell if contains specific text
Replies
4
Views
2K
DanteAmor
DanteAmor

Forum statistics

Threads
1,224,588
Messages
6,179,743
Members
452,940
Latest member
rootytrip

Share this page

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