Another Find and Copy Row help request

[3gswish]

Hi Everyone,

First let me start by saying that I am very much a newbie when it comes to writing VB and macros. I can look at a macro and pretty much figure out what it's doing, but adding to and modifying pretty much results in massive errors. If you suggest something, can you please be so kind as to include the full code?

I've been searching this site, and many others for a macro that will search a worksheet by row for a particular substring and copy that row only once! The substring may exist more than once in a particular cell, or in multiple cells of the same row.

The code that I've found elsewhere on this site and others seems to copy the row for every cell in that row that contains the string. For instance, if the string exists in row 5, column A and column C, I get the row copied twice in the destination sheet.

I think what would help is a way to tell the find to start on the next row once it finds and copies a row. Your suggestions are very much appreciated!

BTW - Thanks for all of the people that have submitted code and made it available to us all! Here is the macro I am currently using.

Sub Macro1()
Dim strLastRow As String
Dim rngC As Range
Dim strToFind As String, FirstAddress As String
Dim wSht As Worksheet
Dim rngtest As String
Application.ScreenUpdating = False
Set wSht = Worksheets("Sheet1")
strToFind = InputBox("Enter Search Criteria")
With wSht.Range("A:C")
Set rngC = .Find(what:=strToFind, LookAt:=xlPart)
If Not rngC Is Nothing Then
FirstAddress = rngC.Address
Do
strLastRow = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1
rngC.EntireRow.Copy Sheets("Sheet2").Cells(strLastRow, 1)
Set rngC = .FindNext(rngC)
Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress
End If
End With
MsgBox ("Finished")
End Sub

 

[craig.penny]

Try this.

Sub Macro1()
    Dim strLastRow As String
    Dim rngC As Range
    Dim strToFind As String, FirstAddress As String
    Dim wSht As Worksheet
    Dim rngtest As String
    Dim iFoundOnRow As Integer 'New line
    Application.ScreenUpdating = False
    Set wSht = Worksheets("Sheet1")
    strToFind = InputBox("Enter Search Criteria")
    With wSht.Range("A:C")
        Set rngC = .Find(what:=strToFind, LookAt:=xlPart)
        If Not rngC Is Nothing Then
            FirstAddress = rngC.Address
            Do
                If iFoundOnRow <> rngC.Row Then 'New line
                    strLastRow = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1
                    rngC.EntireRow.Copy Sheets("Sheet2").Cells(strLastRow, 1)
                    iFoundOnRow = rngC.Row 'New line
                End If 'New line
                Set rngC = .FindNext(rngC)
            Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress
        End If
    End With
    MsgBox ("Finished")
End Sub

 

[alkhema]

Greatings!
I have similar request. I don't want to strat new thread.
So my issue. I'm geting the sales report with data in columns A,B,C,D. What i have to do is manualy type in the item's cost to rows in column E to get profit in G. There is over 300 items and four departments. I can't copy n paste item cost even if ill sort by name in column A coz the number of items keep changing as not everything is being sold each time.

I tghough about uisng formula IF like in the pic above (keep the items and costs in other workbook or copy to the other sheet) which is working fine but I will have to do over 300xIF in the one line.
Is there any simpler way to do this??
Thanks a lot

 

[craig.penny]

Welcome alkhema,

You can handle that with a worksheet formula. Try this is cell E3.

=VLOOKUP(A3,$I$3:$J$5,2,FALSE)

Copy down as far as necessary. Adjust the "$I$3:$J$5" in the formula above as necessary.

 

[alkhema]

Wicked!
Thanks a lot! It does what i wanted (and it's so simple! made me feel embarrassed lol)
Thanks craig.penny

 

[craig.penny]

No problem! I'm glad it worked for you.

 

[3gswish]

Thanks craig.penny, works great! Only issue is that sheet2 must exist or the macro errors out. Not a big deal.

Also, I must be getting old. I found this macro from a similar post that I started around April 2011. This version creates a new destination sheet, plus it adds the original row number which is handy. I've tweaked it a bit but it also does the trick.

Sub ExtractTerm()

    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("C:D,J:J")                                         ' Search range "A:A,C:D" or "A:C"
    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

 

[craig.penny]

Is that code doing everything you need?

 

[3gswish]

Yes, it is. Your code looks a bit cleaner and produces the same results, albiet without the origininal row number. I am now looking into a few formatting tweaks to the destination sheet. I need it to size columns A:C to 45, and to autofit the row height.

 

[3gswish]

So, after fiddling a bit, I've got the output sheet looking like I want. Unfortunately, I've discovered a bit of a problem with the sFind function, and I am sure it's something simple.

A lot of my text looks like:

Blah Blah Blah (see "This and that")

When I try to input any quote characters in the Search dialog, such as (see "This and that") or "(see "This and that")" or (see """This and that"""), the search always returns the message "No match found.

The code from craig.penny indicates finished, but again nothing is found.

I am sure that there is a way to specify the quotes, but I cannot figure it out. Any help would be appreciated.

Here is the code snippet that deals with the find

Sub ExtractTerm()

    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:C")                                              ' Search range "A:A,C:D" or "A:C"
    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

Thanks!!!!