Loop within a given range

[vijehspaul]

Hi,
I have a macro that search for a string and copy-paste the entire row to new place.
Need help for a modifications.
?? Need to set the macro to start pasting the result from a particular cell instead of last row.

Macro i want to modify:

Private Sub Click()

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("Sheet2")
strToFind = InputBox("Enter the SIC code to find")

With ActiveSheet.Range("A1:A100")
Set rngC = .Find(what:=strToFind, LookAt:=xlPart)
If Not rngC Is Nothing Then
FirstAddress = rngC.Address
Do
strLastRow = Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row + 1
rngC.EntireRow.Copy wSht.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


Please help.

Thanks in advance.

 

[Debraj]

Just little bit modification in the existing code.

Sub Click()

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("Sheet2")
strToFind = InputBox("Enter the SIC code to find")

With ActiveSheet.Range("A1:A100")
    Set rngC = .Find(what:=strToFind, LookAt:=xlPart)
    If Not rngC Is Nothing Then
        FirstAddress = rngC.Address
        strLastRow = InputBox("Enter the Row Number from wheer you want to start pasting:")
        Do
            rngC.EntireRow.Copy
            wSht.Cells(strLastRow, 1).Insert
            Set rngC = .FindNext(rngC)
            strLastRow = strLastRow + 1
        Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress
    End If
End With

MsgBox ("Finished")

End Sub

 

[vijehspaul]

Thanks Debraj