Copy rows with a specific value in column A

[Gert-Jan]

Hi, this macro is supposed to copy all the rows with a specific value (in
C25) to another sheet. But, only the first row will be copied. Can someone
help?? Or have a better suggestion??

Sub Copy()
Application.ScreenUpdating = False
With Sheets("Sheet1")
Dim i As Long, sTargetValue As String
sTargetValue = Sheets("Sheet1").Range("C25")
For i = 100 To 1 Step -1
If Cells(i, "A").Text = sTargetValue Then
Rows(i).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Sheets("Sheet1").Select
End If
Next i
End With
End Sub

 

[Don Guillett]

I would suggest using data>filter>autofilter>filter on your value>copy the
bunch at once but
something like this without selections or screen updating needed. UNTESTED

for i 100 to 2 step-1
with sheets("sheet1")
str = .Range("C25")
dlr=sheets("dest").cells(rows.count,"a").end(xlup).row
if .cells(i,"a")=strval then sheets("dest").rows(dlr).value=.rows(i).value
next i
end with

 

[Gert-Jan]

Hi Don,

Thanks for responding. Unfortunally, it doesn´t work: on "Str" I got an
error.

Gert-Jan

 

[Don Guillett]

correct my typo so that str and strval are the same

for i 100 to 2 step-1
with sheets("sheet1")
str = .Range("C25")
dlr=sheets("dest").cells(rows.count,"a").end(xlup).row
if .cells(i,"a")=str then sheets("dest").rows(dlr).value=.rows(i).value
next i
end with

 

[Gert-Jan]

Hi,

Thanks again. Made your macro "working" (read: error-free) with this:

Sub Kopieren()
For i = 100 To 2 Step -1
With Sheets("Blad1")
Strval = .Range("C26")
dlr = Sheets("Blad2").Cells(Rows.Count, "a").End(xlUp).Row
If .Cells(i, "a") = Strval Then Sheets("Blad2").Rows(dlr).Value =
..Rows(i).Value
End With
Next i
End Sub

But it has the same problem: it only copies the first line of my range.

 

[Don Guillett]

tested

Sub Kopieren()
With Sheets("Blad1")
For i = .Cells(Rows.Count, "a").End(xlUp).Row To 2 Step -1
dlr = Sheets("Blad2"). _
Cells(Rows.Count, "a").End(xlUp).Row + 1
Strval = .Range("C26")
If .Cells(i, "a") = Strval Then _
Sheets("Blad2").Rows(dlr).Value = .Rows(i).Value
Next i
End With
End Sub

 

[Gert-Jan]

Thanks, works great!

tested

Sub Kopieren()
With Sheets("Blad1")
For i = .Cells(Rows.Count, "a").End(xlUp).Row To 2 Step -1
dlr = Sheets("Blad2"). _
Cells(Rows.Count, "a").End(xlUp).Row + 1
Strval = .Range("C26")
If .Cells(i, "a") = Strval Then _
Sheets("Blad2").Rows(dlr).Value = .Rows(i).Value
Next i
End With
End Sub

 

[Don Guillett]

glad to help