Appending the rows in excel

[manchiraju]

hi all,

i have my data in a excel sheet and now i have to write a vba programme by which a particular columns value is checked in the entire sheetand if it corresponds our condition then the entire row has to be selected and should be appended in new row in another sheet of the work book.

so if i have a total of 5000 rows in excel sheet as data and the vlaues in a particular column which satisfy my pre condition are 1000in number, all these corresponding 1000 rows should be selected and pasted in a new sheet.....

pls help me out..........

thanking you in advance

 

[ilses]

Hi,

Perhaps you can use something like this:

Sub AppendRows()

Dim rng As Range
Dim lngRows As Long
Dim lngCounter As Long
Dim lngDestRow As Long

'Find the last row with data in column A
lngRows = Worksheets("Sheet1").Cells(65536, 1).End(xlUp).Row

'Set the range to work on to A1:AlngRows
Set rngArea = Worksheets("Sheet1").Range(Cells(1, 1), Cells(lngRows, 1))

'Set the destination row to the last empty row in Sheet2
'Leave row 1 empty to insert headers
lngDestRow = Worksheets("Sheet2").Cells(65536, 2).End(xlUp).Row + 1


'Loop through range, from last row to A1
With rngArea
 'To loop from top to bottom use lngCounter = 1 to lngRows Step 1
 'Stepping backwards is necessary only if rows have to be delete after copying
 For lngCounter = lngRows To 1 Step -1
        'Replace ".Value > 0" with your condition
        If .Cells(lngCounter, 1).Value > 0 Then
        .Cells(lngCounter, 1).EntireRow.Copy Destination:=Worksheets("Sheet2").Cells(lngDestRow, 1)
        lngDestRow = lngDestRow + 1
        End If
    Next lngCounter
End With

End Sub

Hope this gets you started off.

Ingrid

 

[manchiraju]

thx a million....... ilses,

it indeed provided a good start for me n i could achieve the desired result!!!!!

but it takes more than 100 secs to execute the code.....ne suggestionns to improve the speed..

With Regards,

 

[ilses]

Manchiraju,

Admittedly I didn't take speed into account but should've done as you indicated that you have to deal with a lot of data.

At the start of your procedure include

Application.ScreenUpdating = false
Application.Calculation = xlCalculationManual

and at the end

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = true

.
In general, this helps.

In this case, maybe the looping and copy method could be improved upon. Setting a target range's value or formula to the value of a source range can be faster than copying. Instead of using the "lngCounter" to loop, include Dim c As Range and replace the loop "With rngArea .. End With" by

For Each c In rngArea
        If c.Value > 0 Then
        Worksheets("Blad2").Range(lngDestRow & ":" & lngDestRow).Formula = Worksheets("Blad1").Range(c.Row & ":" & c.Row).Formula
        lngDestRow = lngDestRow + 1
        End If
Next c

(Replace Formula by Value if you only need to copy values.)

Hope this helps,


Ingrid

 

[manchiraju]

hi ilses,

indeed ur smaple code helped to reduce the execution time drastically( now its hardly 4-5 secs)

thanks for that.....but if have to check the values in 2 or 3 seperate columns at a time and then copy such rows in which all the three column values are ssatisfied into a new sheet, how can i procede?

for example i have to check the value in column A, columnX, ColumnCD etc...n then copy such rows into a new sheet .....pls suggest.......

thanks a billion

with regards

 

[ilses]

I took "a particular column's" to mean you'd be looking at one column only.

Before writing more flexible code yourself, have you considered using Excel's Advanced Filter to filter out the appropiate rows? The result can be copied to another location – and it's fast. If the procedure must be coded, setting up a test with a few sample rows and running the macro recorder will give you something like this to start working from:

Sheets("Data&quot.Range("A16&quot.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Criteria&quot.Range("A12&quot, CopyToRange:=Range("A1&quot _
, Unique:=False

Kind regards