Copy row if a range of column matches a value [Solved/Closed]

NoraRoberts - Jan 14, 2010 at 02:28 PM - Latest reply:  scottrm20
- Jan 30, 2012 at 10:51 AM
Could you please help me with the following macro.

The following macro basically copies the entire row if the column B contains the value "1". But in my case, I would like to copy the entire row if a range of column (for ex: B via Z) contains the value "1". It would even be better, if the user could input a number/string and then if the column range from B via Z contains that specific string/number - it will automatically copy the entire row that contains that value in a new worksheet/xls file.

Hope to hear from you.

Thanks!
N.



Sub SearchForNumber1()

Dim LSearchRow As Integer
Dim LCopyToRow As Integer

On Error GoTo Err_Execute

'Start search in row 1
LSearchRow = 1

'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 2

While Len(Range("A" & CStr(LSearchRow)).Value) > 0

'If value in column E = "Mail Box", copy entire row to Sheet2
If Range("B" & CStr(LSearchRow)).Value = "1" Then

'Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy

'Paste row into Sheet2 in next row
Sheets("Sheet2").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste

'Move counter to next row
LCopyToRow = LCopyToRow + 1

'Go back to Sheet1 to continue searching
Sheets("Sheet1").Select

End If

LSearchRow = LSearchRow + 1

Wend

'Position on cell A3
Application.CutCopyMode = False
Range("A3").Select

MsgBox "All matching data has been copied."

Exit Sub

Err_Execute:
MsgBox "An error occurred."

End Sub
See more 

23 replies

Best answer
tompols 1227 Posts Wednesday July 28, 2004Registration dateContributorStatus November 25, 2013 Last seen - Jan 15, 2010 at 02:18 AM
21
Thank you
Hi,
the first code I wrote was looking for cells having the exact same value as the entered string.
here's an update that looks for cells containing the string:
Sub customcopy()
Dim strsearch As String, lastline As Integer, tocopy As Integer

strsearch = CStr(InputBox("enter the string to search for"))
lastline = Range("A65536").End(xlUp).Row
j = 1

For I = 1 To lastline
    For Each c In Range("B" & I & ":Z" & i)
        If InStr(c.Text, strsearch) Then
            tocopy = 1
        End If
    Next c
    If tocopy = 1 Then
        Rows(i).Copy Destination:=Sheets(2).Rows(j)
        j = j + 1
    End If
tocopy = 0
Next i

End Sub

Thank you, tompols 21

Something to say? Add comment

CCM has helped 1831 users this month

10
Thank you
Hi,
I had a similar problem, but I need to search for keywords using a list of words. Can you guys help me figure out how to replace the inputbox feature with a list of words?

Thanks a lot in advance!
tompols 1227 Posts Wednesday July 28, 2004Registration dateContributorStatus November 25, 2013 Last seen - Jan 14, 2010 at 03:29 PM
3
Thank you
Hi NoraRoberts,
try this :
Sub customcopy()
Dim strsearch As String, lastline As Integer, tocopy As Integer

strsearch = CStr(InputBox("enter the string to search for"))
lastline = Range("A65536").End(xlUp).Row
j = 1

For I = 1 To lastline
    For Each c In Range("B" & I & ":Z" & i)
        If c.Text = strsearch Then
            tocopy = 1
        End If
    Next c
    If tocopy = 1 Then
        Rows(i).Copy Destination:=Sheets(2).Rows(j)
        j = j + 1
    End If
tocopy = 0
Next i

End Sub

let me know if it works as you want....
@rizvisa1. thanks for your answer.

What I mean is the following:

Range(Cells(I, "A"), Cells(I, "F")).Copy Destination:=Sheets(4).Cells(j, "A")

This line just copy the cell as it is, but the cell I am copying it from container Formula, so what I run the macro is copying the formula so I am getting #ref .

I want the code to copy visible values only .

I tried adding .Value.. couldn't make it to work, also my friend tried to help me, but it also been some time since he was using VB.

Thanks :)
Ah, never mind, I fixed it by replacing this:
Range(Cells(I, "A"), Cells(I, "F")).Copy Destination:=Sheets(4).Cells(j, "A")

with this:
Range(Cells(I, "A"), Cells(I, "F")).Copy
Sheets(4).Cells(j, "A").PasteSpecial (xlValues)


Thanks anyway, take care.
Man I am annoying :p
Pls bear with me.
I just tested the formula, on alot of entry, it will flicker the screen simultansly and the copy / paste speed is very slow.

the first formula is still very fast and less annoying than the second.

so, if we can adjust this to copy just values, it will be suberb :
Range(Cells(I, "A"), Cells(I, "F")).Copy Destination:=Sheets(4).Cells(j, "A")
Man I speak way early :p

I used the following code to speed up the formula (.pastespecial) and stop screen flickering

Application.ScreenUpdating=False


Application.ScreenUpdating=True


make it quite better
Hey I have the same problem but I need the macro to Match a PSN number on sheet one with a PSN Number on Sheet 2. A PSN number looks like this 133381. If it finds a match then it cuts all the data from the row Range(A:AS) and pastes it to the last column in Sheet 1 Column W. I want this to keep going until all the data on Sheet 2 is gone because it has moved to the end of all the data on Sheet 1.
2
Thank you
Hi,

Instead of finding a value by the user input in InputBox, I have words already listed that I want to find and copy.

Sheet 1: I would want the result be pasted here
ProductID, Price, ReferenceID, other columns

Sheet2: I have List of ProductID and Price. The list of ProductID are the ones that may or may not be listed in Sheet3. I want to search the ProductsID in this sheet that matches ProductID in Sheet3.

Sheet3: I have List of ProductID and corresponding ReferenceID and other columns in which I want to copy all row for matching ProductID.

Thank you for your help!!!
2
Thank you
I'm trying to do something similar as well...
I have 1 workbook with 30 sheets (all custom named)

I want to pull the entire row if the value in column O in each sheet contains the word "Yes"

and I want it all on one "summary" page

is this possible thru this? Sorry for thread crapping if you'd like I can open a new thread.

thanks
1
Thank you
I was wondering if you could help me as well as it appears you have greatly assisted the previous individual. I am trying to copy an entire row from worksheet named "Gallagher" to another worksheet named "CURRENT" if column D (from Gallagher) contains the text "No". I have multiple worksheets within the workbook that I would like to link to the "CURRENT" worksheet if the column D contains the next "No" so ultimately would like the code to be able to recognize the last unused row/cell in "CURRENT" so when it pastes rows from the other worksheets, it will know where to begin pasting.

Thanks so much in advance!
Bri
rizvisa1 4481 Posts Thursday January 28, 2010Registration dateContributorStatus January 6, 2016 Last seen - Aug 5, 2010 at 10:27 AM
Bri, you can filter the column on "No"
Copy the visible rows
paste on the "current sheet"

For last used row

try this

Set Cell = Sheets("Current").Cells.Find("*", 1,1), SearchOrder:=xlByRows, SearchDirection:= xlPrevious)

If Cell is Nothing then
lastrow = 1
else
lastrow = cell.row +1
end if
0
Thank you
Hello,

I also had a similar question that I am having issues with. I have a tab named "Data" and 2 other tabs named Bill and Jim. Column A in the Data tab contains Names of employees (Jim and Bill) and all employees have a corresponding tab. What I am trying to do is match the names in column A of the "data" tab with the corresponding sheets that have the same names and then paste the names into their respective sheets in column A. Everytime I populate I am trying to get it to paste in the next empty row. In the "data" tab there might be 5 entries for Jim and 3 for Bill and I am trying to get the 5 Jim entries to paste in the Jim tab and the 3 Bill entries to paste in the Bill tab. Any help on this would be greatly appreciated as I have been struggling with it for the past few hours.

Thanks so much for your help in advance.
rizvisa1 4481 Posts Thursday January 28, 2010Registration dateContributorStatus January 6, 2016 Last seen - Dec 9, 2011 at 10:38 AM