Copying rows to a new sheet
 

We have some infection control data which is stored on 12
sheets, 1 for each month. Each row on a sheet is data. We
would like to make a new sheet for totals, and have it
automatically copy all rows of data from the other 12 onto
itself, so basically we have an anual summary sheet.

How can this be accomplished?

update...
 

Making a little progress. I found the following script
online and have tried this. This is very close. I just
need it to do the following:

When it makes a sheet called Master and copies, start
copying the data at row 3 (row 1 & 2 are headers).

I have it hard coded to copy from A3 to R30. I will always
start at A3, but the data may go past row R, it may not. I
would like this to check and keep copying rows until Row A
contains a blank value in column 1.... essentially I do
not want ot hard code the rows to copy.


Sub CopyRange()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
'If SheetExists("Master") = True Then
' MsgBox "The sheet Master already exist"
' Exit Sub
'End If
Application.ScreenUpdating = False
Set DestSh = Worksheets.Delete
Set DestSh = Worksheets.Add
DestSh.Name = "Master"
For Each sh In ThisWorkbook.Worksheets
If sh.Name < DestSh.Name And sh.Name
< "Definitions" Then
If sh.UsedRange.Count 1 Then
Last = LastRow(DestSh)
sh.Range("A3:R30").Copy DestSh.Cells(Last
+ 1, 1)
End If
End If
Next
Application.ScreenUpdating = True
End Sub

Sub CopyRangeValues()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
' If SheetExists("Master") = True Then
' MsgBox "The sheet Master already exist"
' Exit Sub
'End If
Application.ScreenUpdating = False

Set DestSh = Worksheets.Add
DestSh.Name = "Master"
For Each sh In ThisWorkbook.Worksheets
If sh.Name < DestSh.Name And sh.Name
< "Definitions" Then
If sh.UsedRange.Count 1 Then
Last = LastRow(DestSh)
With sh.Range("A3:R30")
DestSh.Cells(Last + 1, 1).Resize
(.Rows.Count, _
.Columns.Count).Value = .Value
End With
End If
End If
Next
Application.ScreenUpdating = True
End Sub

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

Function Lastcol(sh As Worksheet)
On Error Resume Next
Lastcol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function

Function SheetExists(SName As String, _
Optional ByVal WB As Workbook) As
Boolean
On Error Resume Next
If WB Is Nothing Then Set WB = ThisWorkbook
SheetExists = CBool(Len(Sheets(SName).Name))
End Function

Copying rows to a new sheet
 

Sub CopyData()
Dim sh as Worksheet, rng as Range
for each sh in ActiveWorkbook.Worksheets
if lcase(sh.name) < "summary" then
set rng = sh.Range("A1").CurrentRegion
rng.copy Destination:=Worksheets("Summary") _
.Cells(rows.count,1).End(xlup)(2)
end if
Next
End Sub

This assumes your data starts in Cell A1 and there are no completely blank
rows or columns within the data.

if you have a header on each sheet, it will be copied. If you want to avoid
that
Sub CopyData()
Dim sh as Worksheet, rng as Range
for each sh in ActiveWorkbook.Worksheets
if lcase(sh.name) < "summary" then
set rng = sh.Range("A1").CurrentRegion.Offset(1,0)
rng.copy Destination:=Worksheets("Summary") _
.Cells(rows.count,1).End(xlup)(2)
end if
Next
End Sub

--
Regards.
Tom Ogilvy


"Dave" wrote in message
...
We have some infection control data which is stored on 12
sheets, 1 for each month. Each row on a sheet is data. We
would like to make a new sheet for totals, and have it
automatically copy all rows of data from the other 12 onto
itself, so basically we have an anual summary sheet.

How can this be accomplished?

update...
 

Sub CopyData()
Dim sh as Worksheet, rng as Range
On error resume next
set sh = worksheets("Summary")
On error goto 0
if sh is nothing then
with ActiveWorkbook
.worksheets.Add After:=.Worksheets(.Worksheets.count)
End with
Activesheet.Name = "Summary"
End if
for each sh in ActiveWorkbook.Worksheets
if lcase(sh.name) < "summary" then
set rng = sh.Range("A1").CurrentRegion.Offset(2,0)
rng.copy Destination:=Worksheets("Summary") _
.Cells(rows.count,1).End(xlup)(2)
end if
Next
End Sub

--
Regards,
Tom Ogilvy

"Dave" wrote in message
...
Making a little progress. I found the following script
online and have tried this. This is very close. I just
need it to do the following:

When it makes a sheet called Master and copies, start
copying the data at row 3 (row 1 & 2 are headers).

I have it hard coded to copy from A3 to R30. I will always
start at A3, but the data may go past row R, it may not. I
would like this to check and keep copying rows until Row A
contains a blank value in column 1.... essentially I do
not want ot hard code the rows to copy.


Sub CopyRange()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
'If SheetExists("Master") = True Then
' MsgBox "The sheet Master already exist"
' Exit Sub
'End If
Application.ScreenUpdating = False
Set DestSh = Worksheets.Delete
Set DestSh = Worksheets.Add
DestSh.Name = "Master"
For Each sh In ThisWorkbook.Worksheets
If sh.Name < DestSh.Name And sh.Name
< "Definitions" Then
If sh.UsedRange.Count 1 Then
Last = LastRow(DestSh)
sh.Range("A3:R30").Copy DestSh.Cells(Last
+ 1, 1)
End If
End If
Next
Application.ScreenUpdating = True
End Sub

Sub CopyRangeValues()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
' If SheetExists("Master") = True Then
' MsgBox "The sheet Master already exist"
' Exit Sub
'End If
Application.ScreenUpdating = False

Set DestSh = Worksheets.Add
DestSh.Name = "Master"
For Each sh In ThisWorkbook.Worksheets
If sh.Name < DestSh.Name And sh.Name
< "Definitions" Then
If sh.UsedRange.Count 1 Then
Last = LastRow(DestSh)
With sh.Range("A3:R30")
DestSh.Cells(Last + 1, 1).Resize
(.Rows.Count, _
.Columns.Count).Value = .Value
End With
End If
End If
Next
Application.ScreenUpdating = True
End Sub

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

Function Lastcol(sh As Worksheet)
On Error Resume Next
Lastcol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function

Function SheetExists(SName As String, _
Optional ByVal WB As Workbook) As
Boolean
On Error Resume Next
If WB Is Nothing Then Set WB = ThisWorkbook
SheetExists = CBool(Len(Sheets(SName).Name))
End Function

update...
 

Thank you!