Copy Data from several sheets into one issue

[mirox]

Hereby the macro to copy data from several sheets starting from row 2
till the last row with data - except header(use the function LastRow)

But I want to copy the all data from these sheets plus header data
from one of these sheets named i.e. MON

Please let me know how to modify code to ensure that additionally
header data will be copied but only from on sheet.

Many thanks.
Rgds.

********************************************************************************************************************
Sub CopyData()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("WEEK").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "WEEK"
StartRow = 2
For Each sh In ActiveWorkbook.Worksheets
If IsError(Application.Match(sh.Name, _
Array(DestSh.Name, "RPT - MON",
"RPT - TUE", "RPT - WED", "RPT - THU", "RPT - FRI", "RPT - SAT", "RPT
- SUN", "WEEK TOTAL"), 0)) Then
Last = LastRow(DestSh)
shLast = LastRow(sh)
If shLast > 0 And shLast >= StartRow Then
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows
(shLast))
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
End If
Next
ExitTheSub:
Application.GoTo DestSh.Cells(1)
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
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

********************************************************************************************************************

 

[Joel]

Try this change

From:
DestSh.Name = "WEEK"
StartRow = 2
For Each sh In ActiveWorkbook.Worksheets


To:

DestSh.Name = "WEEK"
First = True
StartRow = 2
For Each sh In ActiveWorkbook.Worksheets
If First = True then
sh.rows(1).copy destination:=DestSh.Rows(1)
First = False
End If

 

[Bernie Deitrick]

See two minor changes below, denoted by '********

HTH,
Bernie
MS Excel MVP


Sub CopyData()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With


Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("WEEK").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "WEEK"

'*******change StartRow to 1 instead of 2
StartRow = 1

For Each sh In ActiveWorkbook.Worksheets
If IsError(Application.Match(sh.Name, _
Array(DestSh.Name, "RPT - MON",
"RPT - TUE", "RPT - WED", "RPT - THU", "RPT - FRI", "RPT - SAT", "RPT
- SUN", "WEEK TOTAL"), 0)) Then
Last = LastRow(DestSh)
shLast = LastRow(sh)
If shLast > 0 And shLast >= StartRow Then
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows
(shLast))
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False

'************* Add this line after a successful copy, to no longer copy headers
If StartRow = 1 Then StartRow = 2

End With
End If
End If
Next
ExitTheSub:
Application.GoTo DestSh.Cells(1)
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
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