CopyPaste copying headers

andysh

Board Regular
Joined
Nov 8, 2019
Messages
73
I have the below code copying data from multiple worksheets on to a master worksheet without the header row. It works fine if data is entered however if no data is entered on a sheet it copies the header row. How can I change it so that the header row is always ignored even if it is the only row of data on a sheet?

OptionExplicit

SubCollate_Sheets()

Dim ws As Worksheet, sh As Worksheet
Set sh = Sheets("Triage")
Dim lr As Long, lrw As Long, lc As Long

Application.ScreenUpdating= False

ForEach ws In Worksheets
If ws.Name <> "Triage" And ws.Name <> "Lists"Then
lrw = ws.Range("A" &Rows.Count).End(xlUp).Row
lc = ws.Cells(1, Columns.Count).End(xlToLeft).Column
lr = sh.Range("A" & Rows.Count).End(xlUp).Row + 1
ws.Range(ws.Cells(2, 1), ws.Cells(lrw, lc)).Copy
sh.Range("A" & lr).PasteSpecial xlPasteValues
ws.Range(ws.Cells(2, 1), ws.Cells(lrw, lc)).EntireRow.Delete
End If
Next ws

Application.CutCopyMode= False

Application.ScreenUpdating= True

MsgBox" Completed ! "

End Sub
 

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
75,392
Office Version
365
Platform
Windows
Check the value of lrw, if it's 1 then there's no data to copy and the header will be copied so skip the sheet
Code:
Sub Collate_Sheets()
Dim ws As Worksheet, sh As Worksheet
Dim lr As Long, lrw As Long, lc As Long
        
    Application.ScreenUpdating = False
    
    Set sh = Sheets("Triage")
    
    For Each ws In Worksheets
    
        If ws.Name <> "Triage" And ws.Name <> "Lists" Then
                        
            lrw = ws.Range("A" & Rows.Count).End(xlUp).Row
            
            If lrw <> 1 Then
                lc = ws.Cells(1, Columns.Count).End(xlToLeft).Column
                lr = sh.Range("A" & Rows.Count).End(xlUp).Row + 1
                ws.Range(ws.Cells(2, 1), ws.Cells(lrw, lc)).Copy
                sh.Range("A" & lr).PasteSpecial xlPasteValues
                ws.Range(ws.Cells(2, 1), ws.Cells(lrw, lc)).EntireRow.Delete
            End If
            
        End If
        
    Next ws
    
    Application.CutCopyMode = False
    
    Application.ScreenUpdating = True
    
    MsgBox " Completed ! "

End Sub
 

Forum statistics

Threads
1,085,547
Messages
5,384,377
Members
401,892
Latest member
martyg

Some videos you may like

This Week's Hot Topics

Top