copy rows to another file

[climate]

Dear Experts
I have following code,i need to copy desirde rows to new file (r.xls) on
sheet 1.
This code is able to copy desired rows from active sheet to sheet2(same
file) based on values in column G.

Would you please guide me?
regards

Sub Marine()
Dim arrParts() As String
Dim MyRange As Range, CopyRange As Range
Dim LastRow As Long
LastRow = Cells(Cells.Rows.Count, "G").End(xlUp).Row
Set MyRange = Range("G1:G" & LastRow)
response = InputBox("Enter rows to copy in the format nnn,nnn,nn")
arrParts = Split(response, ",")
For Each C In MyRange
For Each strPart In arrParts
If C.Value = Val(strPart) Then
If CopyRange Is Nothing Then
Set CopyRange = C.EntireRow
Else
Set CopyRange = Union(CopyRange, C.EntireRow)
End If
End If
Next
Next

If Not CopyRange Is Nothing Then
LastRow = Sheets("Sheet2").Cells(Cells.Rows.Count, "A").End(xlUp).Row
CopyRange.Copy Sheets("Sheet2").Range("A" & LastRow + 1)
End If
End Sub

 

[Jacob Skaria]

Hi Climate

Try the below. Re-written the code so that you can enter the values in any
order....



Sub Marine()
Dim CopyRange As Range, wsTarget As Worksheet, lngRow As Long


response = InputBox("Enter rows to copy in the format nnn,nnn,nn")

For lngRow = 1 To Cells(Rows.Count, "G").End(xlUp).Row
If IsError(Range("G" & lngRow)) = False And Range("G" & lngRow) <> "" Then
If InStr("," & response & ",", "," & Range("G" & lngRow).Value & ",") > 0 Then
If CopyRange Is Nothing Then
Set CopyRange = Rows(lngRow)
Else
Set CopyRange = Union(CopyRange, Rows(lngRow))
End If
End If
End If
Next

Set wsTarget = Workbooks("r.xls").Sheets("Sheet1")
If Not CopyRange Is Nothing Then
lngRow = wsTarget.Cells(Cells.Rows.Count, "A").End(xlUp).Row
CopyRange.Copy wsTarget.Range("A" & lngRow + 1)
End If

End Sub

 

[climate]

Hi Jacob
How are you?
Your changes on that code is very nice,and work's correctly.
Thank you very much.

best regards

 

[Jacob Skaria]

Thanks for the feedback..