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
Display More