1 row exception from VBA Copy Range

Question

I am working on some code to combine several sheets that form separate parts lists into one large parts list.

So far, I have 2 functions that scan each worksheet for the last row and column

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

and

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

Then I have another subsection that creates a new sheet called “Parts List” and inserts ranges there.

Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

' Delete the summary sheet if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Parts List").Delete
On Error GoTo 0
Application.DisplayAlerts = True

' Add a new summary worksheet.
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Parts List"


' Loop through all worksheets and copy the data to the
' summary worksheet.
For Each sh In ActiveWorkbook.Worksheets
    If sh.Name <> DestSh.Name Then

        ' Find the last row with data on the summary worksheet.
        Last = LastRow(DestSh)

        ' Specify the range to place the data.
        ' Set CopyRng = sh.Range("B3:G10").
        Set CopyRng = sh.UsedRange

        ' Test to see whether there are enough rows in the summary
        ' worksheet to copy all the data.
        If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
            MsgBox "There are not enough rows in the " & _
               "summary worksheet to place the data."
            GoTo ExitTheSub
        End If

        ' This statement copies values and formats from each
        ' worksheet.
        CopyRng.Copy
        With DestSh.Cells(Last + 1, "A")
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
        End With

        ' Optional: This statement will copy the sheet
        ' name in the H column.
        DestSh.Cells(Last + 1, "I").Resize(CopyRng.Rows.Count).Value = sh.Name

    End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

' AutoFit the column width in the summary sheet.
DestSh.Columns.AutoFit

With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With
End Sub

The problem I am facing is that the header lines are copied with ranges. Does anyone know how to exclude headers from scanning rows and columns or from copying?

Thanks for any help Dan

Answer 1

, - , , union. , , totalrange .

Dim row as integer
Dim temprange as range
Dim totalrange as range
Dim startrow as integer
For row = 2 to lastrow+1  `assuming there is always a title in row 1
If IsNum(Cells(row,1)) = false Then
    If temprange = Nothing then
         Set temprange = Range(Cells(2,1),Cells(row-1,[lastcolumn number] `[replace with number of last column]
         startrow = row+1
    Else
         Set temprange = Range(Cells(startrow,1),Cells(row-1,[lastcolumn number])
    End if
    If totalrange <> Nothing then
          Set totalrange = Union(totalrange,temprange)
    Else
          Set totalrange = temprange
    End if
End if
Next row

,

For row = lastrow to 1 step -1
If IsNum(Cells(row,1) = False then
    Rows(row).EntireRow.Delete
End if
Next row

.

Answer 2

1 , . , lngTitleRows:

Option Explicit

Sub Test()

    UsedRangeLessFirstRow(Sheet1, 1).Select

End Sub

Function UsedRangeLessFirstRow(ws As Worksheet, lngTitleRows As Long) As Range

    Dim rngData As Range
    Dim lngDataRows As Long
    Dim lngDataColumns As Long

    Set rngData = ws.UsedRange
    lngDataRows = rngData.Rows.Count - lngTitleRows
    lngDataColumns = rngData.Columns.Count
    Set rngData = rngData.Offset(1, 0).Resize(lngDataRows, lngDataColumns)

    Set UsedRangeLessFirstRow = rngData

End Function

:

Set CopyRng = sh.UsedRange

:

Set CopyRng = UsedRangeLessFirstRow(sh, 1)

Answer 3

Range, Range , Intersect-Offset:

Set CopyRng = Intersect(CopyRng, CopyRng.Offset(1))

It just takes your given Range, shifts it by one line, and then saves only the part that intersects with the original Range.

With this new one, Rangeyou can safely execute your own CopyRng.Copyand exclude the title bar.