copy nonblank rows from many worksheets and paste them onto one worksheet

[starman]

Hi:

I am new to VBA. I wonder if there is a marco which I can use to copy
all the nonblank rows from many worksheets and paste them onto one
single worksheet (as text). For example, say I got sheet1, sheet2,
sheet3 and I want to copy all the nonblank cells (except the first row,
which is the title row) of the worksheets to sheet4 as text, so that
all the data will appear on one single sheet. Anyone can help? Thanks
heaps!

Regards,
Starman

 

[Norman Jones]

Hi Starman,

Ron de Bruin has some sample code which may assist you at:

http://www.rondebruin.nl/copy2.htm#CurrentRegion

and

http://www.rondebruin.nl/copy2.htm#UsedRange

 

[auspcs]

You could change this around to do the job

Sub CopyAllToOne()
' The following range is the Destination sheet selection
Application.Goto Reference:="your reference here"
Selection.ClearContents
Dim SourceRange As Range
Dim Destrange As Range
Dim DrTarget As Long
Dim EachSh As Worksheet
Dim DestSh As Worksheet
Application.ScreenUpdating = False
'Sheet1 is the target for the list it has the "your
reference here" reference
Set DestSh = Worksheets("Sheet1")
For Each EachSh In ThisWorkbook.Worksheets
'the following 2 IF statements exlude the target sheet & ANY OTHER
other that isn't wanted in the list
If EachSh.Name <> DestSh.Name Then
If EachSh.Name <> "ANY OTHER" Then
DrTarget = LastRow(Sheets("sheet1")) + 1
With EachSh
The following range can be changed to suit yourself
Set SourceRange = .Range("A2:M" & .Range("A" &
Rows.Count).End(xlUp).Row)
End With
Set Destrange = Sheets("Sheet1").Range("A" & DrTarget)
SourceRange.Copy
Destrange.PasteSpecial xlPasteValues, , False, False
Application.CutCopyMode = False
End If
End If
Next
'The list is now
' We can sort the list
Application.Goto Reference:="Your reference here" 'The same range
as from before
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending,
Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,
_
DataOption1:=xlSortNormal
ActiveWindow.SmallScroll Down:=-1
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending,
Key2:=Range("A2") _
, Order2:=xlAscending, Header:=xlNo, OrderCustom:=1,
MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal,
DataOption2:= _
xlSortNormal
Application.ScreenUpdating = True
' This sub needs the Lastrow function
End Sub
'Lastrow is used to determine which is the last used row of a sheet
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function