CopyPaste copying headers

andysh

Board Regular
Joined
Nov 8, 2019
Messages
105
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
 

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,300
Office Version
  1. 365
Platform
  1. 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,136,799
Messages
5,677,807
Members
419,721
Latest member
StuckInWork

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top