copy several rows

[climate]

Dear experts
I have following code that Jacob has written(very thank's for his help). by
using this code, i can copy only one row to sheet2 based on value of column
G.i need to a macro which able to copy several rows to sheet2.in other words,
when i run macro and open the box for input, take it at least 30 values, and
then copy related rows to sheet2.column G has 4500 cells.

Sub CopyRow()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim varFound As Variant, varSearch As Variant
Dim strAddress As String, lngLastRow As Long

Set ws1 = Sheets("Sheet1") 'source sheet
Set ws2 = Sheets("Sheet2") 'destination sheet

varSearch = InputBox("Find which number in row G and copy it?")
If varSearch = "" Then Exit Sub

With ws1.Columns("G")
Set varFound = .Find(varSearch, LookIn:=xlValues, LookAt:=xlWhole)
If Not varFound Is Nothing Then
strAddress = varFound.Address
Do
lngLastRow = ws2.Cells(Rows.Count, "G").End(xlUp).Row + 1
ws1.Rows(varFound.Row).Copy ws2.Rows(lngLastRow)
Set varFound = .FindNext(varFound)
Loop While Not varFound Is Nothing And _
varFound.Address <> strAddress
End If
End With
End Sub

Any help will be greatly appreciating.

regards

 

[Jacob Skaria]

Hi ..Try the below code....The search items are mentioned in a range in
Sheet3 range A1:A0...Change to suit

Sub CopyRow()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rngSearch As Range, lngRow As Long, lngLastRow As Long

Set ws1 = Sheets("Sheet1") 'source sheet
Set ws2 = Sheets("Sheet2") 'destination sheet
Set rngSearch = Sheets("Sheet3").Range("A1:A10") 'search items

For lngRow = 1 To ws1.Cells(Rows.Count, "G").End(xlUp).Row
If Range("G" & lngRow) <> "" Then
If WorksheetFunction.CountIf(rngSearch, Range("G" & lngRow)) <> 0 Then
lngLastRow = ws2.Cells(Rows.Count, "G").End(xlUp).Row + 1
ws1.Rows(lngRow).Copy ws2.Rows(lngLastRow)
End If
End If
Next

End Sub

 

[Jacob Skaria]

Correction...

Sub CopyRow()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rngSearch As Range, lngRow As Long, lngLastRow As Long

Set ws1 = Sheets("Sheet1") 'source sheet
Set ws2 = Sheets("Sheet2") 'destination sheet
Set rngSearch = Sheets("Sheet3").Range("A1:A10") 'search items

For lngRow = 1 To ws1.Cells(Rows.Count, "G").End(xlUp).Row
If ws1.Range("G" & lngRow) <> "" Then
If WorksheetFunction.CountIf(rngSearch, ws1.Range("G" & lngRow)) <> 0 Then
lngLastRow = ws2.Cells(Rows.Count, "G").End(xlUp).Row + 1
ws1.Rows(lngRow).Copy ws2.Rows(lngLastRow)
End If
End If
Next

End Sub

 

[climate]

Hi
Your code hasn't reaction, box for input (desired value of ColG) not open,
and what is the cause for sheet3?

regards

 

[Jacob Skaria]

Instead of having inputbox's for entering multiple values; you can type in
those values to a different range...I have put that as Sheet3 A1:A10...This
could be changed to another locaiton to suit...

 

[Jacob Skaria]

I thought its a better solution to mention the items in a range than using
Inputbox multiple times.. Sheet3 is just an example. You can change that to
suit..

 

[climate]

Hello Jacob
You are right, i understand your means.
Your macro work's correctly and is very very nice.
Many thank's for you, your help stayed in my mind.
Best wishes
regards

 

[climate]

Hi
I'm sorry,i need to copy A1:A10 on sheet3 just as i enter with it's
arrangment. when i run your code, change arrange of data. would you plesae
complete it.

regards