Copying Entries Help

[James8309]

Hi everyone

I have 5 sheets, Sheet1, Sheet2,Sheet3,Sheet4 and Sheet5

1. Only Sheet1,2,3 and 4 has data on Column A:C from Row 3. Last Row
always changes for those sheets. Column A is always full to the very
last row but column B & C has alot of empty cells.

2. Sheet5 is emtpy, This sheet is for the result

3. What I want to do is find cells in column B for each sheets (From
B3 to Lastrow in columnA) which has values in it ( <>"") then copy
that entire row and paste into Sheet5 (from Row 3)

4. i.e. Perform this for sheet1 then copy paste the result to sheet5
then sheet2's result will be on sheet5 Lastrow and same thing upto
sheet4.

Can anyone help?

Thank you.


regards,

James

 

[Per Jessen]

Hi

Try this:

Sub CopyData()
Application.ScreenUpdating = False
Dim FilterRange As Range
Dim CopyToRange As Range

shArray = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4")
With Sheets("sheet5")
Set CopyToRange = .Range("A3")
End With
For sh = 0 To UBound(shArray)
Sheets(shArray(sh)).Activate
LastRow = Range("A3").End(xlDown).Row
Set FilterRange = Range("A3", Cells(LastRow, "C"))
FilterRange.AutoFilter field:=2, Criteria1:="<>"
FilterRange.copy Destination:=CopyToRange
FilterRange.AutoFilter
With Sheets("Sheet5")
Set CopyToRange = .Range("A3").End(xlDown)
End With
Next
Application.ScreenUpdating = True
End Sub

Regards
Per