Exclude header row from dump

Hi there, Ive got the following module running, it checks to see if a value is over 40, then drops all corresponding rows into another sheet. problem being is that is copies some of my header rows, which are just one row at the start of each sheet. anyone suggest how i can get around this dilemma? I am pretty new to this so please be clear with what why how ect. thanks again

Sub transferdata()
Dim ws As Worksheet
Dim rng As Range, cell As Range, rng1 As Range
Dim lr As Long, lr1 As Long, lrcnt As Long, cnt As Long, m As Long, n As Long
Application.ScreenUpdating = False
For Each ws In ActiveWorkbook.Sheets
If ws.Name <> "Major" Then
lr = ws.Cells(Rows.Count, "H").End(xlUp).Row
Set rng = ws.Range("H2:H" & lr)
n = Application.WorksheetFunction.CountIf(rng, ">40")
cnt = cnt + n
End If
Next ws
lr1 = Sheets("Major").Cells(Rows.Count, "H").End(xlUp).Row
Set rng1 = Sheets("Major").Range("H2:H" & lr1)
m = Application.WorksheetFunction.CountIf(rng1, ">40")
If m < cnt Then

For Each ws In ActiveWorkbook.Sheets
If ws.Name <> "Major" Then
lr = ws.Cells(Rows.Count, "H").End(xlUp).Row
Set rng = ws.Range("H2:H" & lr)
For Each cell In rng
lr1 = Sheets("major").Cells(Rows.Count, "H").End(xlUp).Row + 1
If cell.Value > 40 Then
cell.EntireRow.Copy Destination:=Sheets("Major").Range("A" & lr1)
End If
Next cell
End If
Next ws
End If
Sheets("Major").Activate
Application.ScreenUpdating = True
End Sub

Unless I am missing something it should be skipping your header if your header is in row 1 because of the range set:

Set rng = ws.Range("H2:H" & lr)

Can you submit your workbook for review?

I cannot submit no sorry

So of the 12 months that the sheets represent, only 6 heading rows appear, i am assuming that these are the blanks sheets that ahve no data in them.

Also is there a way to exclude a particular sheet that has values in the h column but is unrelated?

Yes, but without an example copy of your workbook it hard to know how to code it. Best of luck to you.