Looping through a Range and copying to Another Sheet

[Big H]

Hi there,

I am new to VBA, and I am wondering if its possible to do the following:

I have a range of data (dynamic), which shouldn't go any more than 200 rows,
and is within columns A:H. What i want to do is loop through the range and
anything which has "CCLS" within column H, then copy it to sheet CCLS.
Sometimes there might not be "CCLS" within column H, so some sort of error
code may need to be added to make the code work.

tia Harry

 

[Ron de Bruin]

Hi Big H

Try this
http://www.rondebruin.nl/copy5.htm

 

[bobbo]

I think this should work

Sub CpyCCLS()
dim rg1 as range
dim cpyrg as range
dim dest as range
dim i as integer



for i = 1 to 200
set rg1 = Activesheet.Range("H" & i)
if rg1.value = "CCLS" then
set cpyrg = Activesheet.Range("A" & i & ":H" & i)
set dest = Worksheets("CCLS").Range("A65536").End(xlup).offset(1,0)
cpyrg.copy
dest.pastespecial
end if
next

end sub

 

[Big H]

Bobbo,
thanks this is perfect, however would it be possible to copy the row if
columnA = "P" and clomnH = "CCLS"

thanks for your help

Harry

 

[bobbo]

Replace this line of code

if rg1.value = "CCLS" then

with this

if rg1.value = "CCLS" and range("A" & rg1.row).value = "P" then

I think that should do the trick.

 

[Big H]

Ron,
thanks for this, a previous post you sent on deleting rows was excellent
however I modified it slightly to suit my needs. The only problem I have is
when a row shows #N/A it does not get deleted. My code is below, any help
you can give me is appreciated.

Sub DeleteRows()
Dim Firstrow As Long
Dim LastRow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView

Firstrow = ActiveSheet.UsedRange.Cells(1).Row
LastRow = ActiveSheet.UsedRange.Rows.Count + Firstrow - 1

With ActiveSheet
.DisplayPageBreaks = False
For Lrow = LastRow To Firstrow Step -1

If IsError(.Cells(Lrow, "I").Value) Then
'Do nothing, This avoid a error if there is a error in the
cell

ElseIf .Cells(Lrow, "I").Value = "CSVS" Then .Rows(Lrow).Delete
'This will delete each row with the Value "CSVS" in Column
I, case sensitive.

End If
Next
With ActiveSheet
.DisplayPageBreaks = False
For Lrow = LastRow To Firstrow Step -1

If IsError(.Cells(Lrow, "I").Value) Then
'Do nothing, This avoid a error if there is a error in the
cell

ElseIf .Cells(Lrow, "I").Value = "CMPN" Then .Rows(Lrow).Delete
'This will delete each row with the Value "CMPN" in Column
I, case sensitive.

End If
Next
With ActiveSheet
.DisplayPageBreaks = False
For Lrow = LastRow To Firstrow Step -1

If IsError(.Cells(Lrow, "I").Value) Then
'Do nothing, This avoid a error if there is a error in the
cell

ElseIf .Cells(Lrow, "I").Value = "RMAT" Then .Rows(Lrow).Delete
'This will delete each row with the Value "CMPN" in Column
I, case sensitive.

End If
Next
With ActiveSheet
.DisplayPageBreaks = False
For Lrow = LastRow To Firstrow Step -1

If IsError(.Cells(Lrow, "I").Value) Then
'Do nothing, This avoid a error if there is a error in the
cell

ElseIf .Cells(Lrow, "I").Value = "#N/A" Then .Rows(Lrow).Delete
'This will delete each row with the Value "#N/A" in Column
I, case sensitive.

End If
Next
With ActiveSheet
.DisplayPageBreaks = False
For Lrow = LastRow To Firstrow Step -1

If IsError(.Cells(Lrow, "I").Value) Then
'Do nothing, This avoid a error if there is a error in the
cell

ElseIf .Cells(Lrow, "I").Value = "EXTN" Then .Rows(Lrow).Delete
'This will delete each row with the Value "EXTN" in Column
I, case sensitive.

End If
Next
With ActiveSheet
.DisplayPageBreaks = False
For Lrow = LastRow To Firstrow Step -1

If IsError(.Cells(Lrow, "I").Value) Then
'Do nothing, This avoid a error if there is a error in the
cell

ElseIf .Cells(Lrow, "I").Value = "EXRP" Then .Rows(Lrow).Delete
'This will delete each row with the Value "EXRP" in Column
A, case sensitive.

End If
Next
End With

ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End With
End With
End With
End With
End With
End Sub


thanks Harry

 

[Ron de Bruin]

If you want to delete all error cells then use

For Lrow = Lastrow To Firstrow Step -1
If IsError(.Cells(Lrow, "I").Value) Then
.Rows(Lrow).Delete
ElseIf .Cells(Lrow, "I").Value = "CSVS" Then .Rows(Lrow).Delete
End If
Next