Excluding 1 line from VBA Copy Range

Question

I am working on some code to consolidate multiple worksheets which form individual parts lists into 1 large parts list.

So far I have 2 functions which 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

I then have another sub which creates a new worksheet called 'Parts List' and pastes the ranges in 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 issue that I am having is that the title rows are being copied with the ranges. Does anyone know how to exclude the titles from the row and column scan or from being copied?

Thanks for any help Dan

Are the title rows fixed in position, or are they different in cell type? Text vs numerical for example? It would be helpful if you share what your worksheets look like. — Luuklag
– Luuklag, Commented Jul 25, 2017 at 9:30
I have added images of the parts list (I want to remove the rows highlighted orange) and an example of what each individual worksheet looks like — Dan M
– Dan M, Commented Jul 25, 2017 at 9:37
Well the problem is related to the way you copy. You select everything in the sheet and copy it all at once. The code of Robin Mackenzie will remove the first row, but that wouldn't suffice in your example. Personally I would loop through all rows and check if the value in cell A,row is numerical or not. If numerical then copy, else next row. However this might be very consuming in terms of CPU usage. Therefore you would have to define your range in a different way, using the looping mechanism I described. — Luuklag
– Luuklag, Commented Jul 25, 2017 at 9:43
The issue with using a looping mechanism will be the CPU usage. This spreadsheet will be used company wide with individual worksheets having hundreds, if not thousands, of entries. Is there a way around this by implementing a 2nd workbook e.g. calling only rows with a numerical value in column A? — Dan M
– Dan M, Commented Jul 25, 2017 at 9:57
@DanM, I added a one-line approach to this that uses Intersect and Offset. Those functions are typically very fast since they rely on Excel's internal model. — Byron Wall
– Byron Wall, Commented Jul 27, 2017 at 23:16

Luuklag · Accepted Answer · 2017-07-28 14:24:21Z

3

Haven't tested it, but something along these lines should help you by looping through all rows in the cell and making a new range out of this using the union function. Then when all rows are checked for numerical values totalrange can be copied using your code.

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

Second approach, deleting title rows before copying

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

Then call your last row function again and do the rest of your code.

edited Jul 28, 2017 at 14:24

answered Jul 25, 2017 at 10:18

Luuklag

3,91412 gold badges40 silver badges59 bronze badges

Sign up to request clarification or add additional context in comments.

5 Comments

Luuklag Over a year ago

Just came to think of it, another way would be to check for numerical rows, and remove those that aren't. Assuming that you don't need those rows kept.

Dan M Over a year ago

Thanks for the ideas. The first answer worked but, as you said it would, really pulled on the CPU. I'd like to give you second approach ago but I don't understand where I would place it in my code?

Luuklag Over a year ago

I think the best place would be just before: CopyRng.Copy

Byron Wall Over a year ago

That first example is missing some Sets. Not critical since it's not executable code, but some poor soul will fight that if they copy/paste it (as Excel VBA seekers tend to do). Also, excluding a header is a one-liner if you use Intersect and Offset. See my answer.

Luuklag Over a year ago

@ByronWall included them

Robin Mackenzie · Accepted Answer · 2017-07-25 09:31:59Z

2

If you have 1 row as a header row you can use the following function. If you have more then increase the lngTitleRows parameter:

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

Then instead of:

Set CopyRng = sh.UsedRange

Use:

Set CopyRng = UsedRangeLessFirstRow(sh, 1)

answered Jul 25, 2017 at 9:31

Robin Mackenzie

19.4k7 gold badges42 silver badges62 bronze badges

2 Comments

Dan M Over a year ago

Thank you for your answer however it doesn't seem to be working for me. I believe this is for the reason that @Luuklag gave 'You select everything in the sheet and copy it all at once. The code of Robin Mackenzie will remove the first row, but that wouldn't suffice in your example.'.

Robin Mackenzie Over a year ago

Check the code again. It removes the header row for each worksheet usedrange that you copy. Call the function within your loop as I mentioned at the bottom of the answer. HTH

Byron Wall · Accepted Answer · 2017-07-27 23:07:44Z

2

If you have an existing Range and you simply want the same Range without a header row, do a simple Intersect-Offset:

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

This simply takes your given Range, shifts it down one row, and then only keeps the part that intersects with the original Range.

With that new Range, you can safely do your CopyRng.Copy and it will exclude the header row.

answered Jul 27, 2017 at 23:07

Byron Wall

4,0202 gold badges15 silver badges31 bronze badges

3 Comments

Luuklag Over a year ago

Byron, indeed a simple solution. However OP's code shows he copys the entire worksheet at once and the worksheet contains several header rows at unpredictable distance apart. Then looping it all would be the only solution I came to think off.

Byron Wall Over a year ago

@Luuklag, I don't think that's correct based on the first picture. The multiple headers are the result of copying each worksheet each with a single header. You can see the 2nd picture is the output sheet (paste destination) based on the code. The approach above would prevent copying the headers so the output stays clean. The code needs a flag for the first sheet, but otherwise the single line Offset-Intersect is a standard approach for excluding headers.

Luuklag Over a year ago

Ah I see now, I mixed the two screenshots up. Then your approach, just as robin's, is indeed more suited

Collectives™ on Stack Overflow

Excluding 1 line from VBA Copy Range

3 Answers 3

5 Comments

2 Comments

3 Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

3 Answers 3

5 Comments

2 Comments

3 Comments

Your Answer

Sign up or log in

Post as a guest

Related