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
"mirox" <(E-Mail Removed)> wrote in message
news:1ebf7242-4f2c-426f-a46a-(E-Mail Removed)...
> 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
>
> ********************************************************************************************************************
>
Similar Threads
