Vba - copy specific range and NOT entire row

Hello everybody, I am new on OZgrid and a noob in vba (6 months or so) but I love it and puting toghether bits and pieces with a lot of forum readings and codes I found online, I already built some nice applications (nice for a noob )

I am currently working on a new project and I have managed to built userforms for it.

I am stuck however at one macro for this project. This macro opens a message box where the user inputs a number (id) that can be found in all sheets in the column I and then it loops in all the sheets and if it finds the ans number then copies/pastes all the entire rows containing that specific ID; it then pastes it on the sheet I specified in the code.

Now it works, but I need to make two modifications:

1. The code copies/pastes all the rows that have that specific id/number in column I on the destination sheet, but it copies the Entire ROW. I need it to only copy from A to P range of the rows that meet the criteria NOT the entire row. This is very important as the row on the sheets may be very long (up to AG column) and in the destination sheet I only want to be pasted the range from A:P

I know I have to change this line: xRRg.EntireRow.Copy, but I have no idea how. do I need to set another range. How?

2. Second problem, I noticed it copies twice some rows, I do not know why and this is not ok, as it messes up the totals I will calculate...

Here is the code I have been working with. Any help will be highly appreciated. Thank you in advance

Public Sub CopyRows_document()
Dim xWs As Worksheet
Dim xCWs As Worksheet
Dim xRg As Range
Dim xStrName As String
Dim xRRg As Range
Dim xC As Integer
Dim ans As String
On Error Resume Next
Application.DisplayAlerts = False
xStr = "Document"
ans = "0000"
Set xCWs = ActiveWorkbook.Worksheets.Item(xStr)
If Not xCWs Is Nothing Then
xCWs.Delete
End If
Set xCWs = ActiveWorkbook.Worksheets.Add
xCWs.Name = xStr
ans = InputBox("Document")
xC = 3
For Each xWs In ActiveWorkbook.Worksheets
If xWs.Name <> xStr Then
Set xRg = xWs.Range("P:P")
Set xRg = Intersect(xRg, xWs.UsedRange)
For Each xRRg In xRg
If xRRg.Value = ans Then
xRRg.EntireRow.Copy
xCWs.Cells(xC, 1).PasteSpecial xlPasteValuesAndNumberFormats
xC = xC + 1
End If
Next xRRg
End If
Next xWs
Application.DisplayAlerts = True
End Sub

rory thank you very much for answering and for help.

I changed the line intersect to Set xRg=Intersect(xRRg.EntireRow, xWs.Range("A:P")).Copy as per your input, but it still copies the entire row.

I'm sure it is my error. Should I also change the xRRg.EntireRow.Copy line somehow, or was it that line in the first place I should have changed?

Thank you in advance

EDIT

I have made the follwing changes in the code and now it works, it copies the rows conainting the Id but only from A:P

The problem is the code has now become very slow, while before these changes it was really fast despite the many sheets it has to loop through. Any suggestions?

Besides, what If I wanted the code to copy non adiacent cells? Would this be possible. Let's say for example copy rows only cells, A, b, C, H, J ,Z, AA. Thank you rory and anyone willing to help, really appreciated.

For Each xWs In ActiveWorkbook.Worksheets

If xWs.Name <> xStr Then

Set xRg = xWs.Range("P:P")

Set xRg = Intersect(xRRg.EntireRow, xWs.Range("A:P"))

For Each xRRg In xRg

If xRRg.Value = ans Then

Intersect(xRRg.EntireRow, xWs.Range("A:P")).Copy

xCWs.Cells(xC, 1).PasteSpecial xlPasteValuesAndNumberFormats

xC = xC + 1

thank you

I changed it agian, of course it was my error, your line was a clear rply to my request...sorry Now it is fast and precise.

This was the only lne I had to change: xRRg.EntireRow.Copy

Changed it as per your suggestion to Intersect(xRRg.EntireRow, xWs.Range("A:P")).Copy

Works perfectly and does not copy twice any row.

Thank you so so very much, you helped tremendously.

If you are willing to help any further, I have one more request:

1. The destination sheet looses any headers or fixed formating I give and I would like for it to keep headers and formating if possible. How can I do that?

Thank you again.

rory thnk you very much. I cancelled the lines that told the code to delete the sheet, now it maintaines headers and formating.

I know you already helped a bunch but I have one more request, if you will be so kind to help.

It seems that sometimes, it still copies twice a row. This is a big no no for the use intended.

So I need to add a line in the code that specifies to copy and paste only ONCE every row that meets the id criteria.

Can you please help? Anyhow again thank you.

rory thank you very much for your last reply.

Exit for does not work, because it makes the for loop stop after copying and pasting the first row with that id. So he finds the first row that meets the criteria, pastes it and then exits so he ignores all the other rows.

Thank you very much anyway. Much apreciated all the great suggestions you have provided me.

Oh just for the record, I wanted to let you know that starting from your suggestion I also figured out how to copy only certain cells (non contiguous) from the row that meets criteria and not the entire row. For example A-C, H, P, Z.

Thank you again

I agree Rory, the original code should not copy one row more than once. You understood perfectly, however due to so many rows maybe, it sometimes copies twice some of the rows. Hoever I chose a target column that can not have dupplicates in it and added .Remove dupplicates, so I think I solved this snarl.

Thank you very much rory, you have been of great help to me!!