Sub CombineSheetsIntoSheet() Dim wb As Workbook Dim j As Integer, wsNew As Worksheet Dim rngCopy As Range, rngPaste As Range Dim Location As String Set wb = ActiveWorkbook On Error Resume Next Set wsNew = wb.Sheets("Combined") On Error GoTo 0 'if sheet does not already exist, create it If wsNew Is Nothing Then Set wsNew = wb.Worksheets.Add(before:=wb.Sheets(1)) ' add a sheet in first place wsNew.Name = "Combined" End If 'copy headings and paste to new sheet starting in B1 With wb.Sheets(2) .Range(.Range("A1"), .Cells(1, Columns.Count) _ .End(xlToLeft)).Copy wsNew.Range("B1") End With ' work through sheets For j = 2 To wb.Sheets.Count ' from sheet 2 to last sheet 'save sheet name/location to string Location = wb.Sheets(j).Name 'set range to be copied With wb.Sheets(j).Range("A1").CurrentRegion Set rngCopy = .Offset(1, 0).Resize(.Rows.Count - 1) End With 'set range to paste to, beginning with column B Set rngPaste = wsNew.Cells(Rows.Count, 2).End(xlUp).Offset(2, 0) 'copy range and paste to column *B* of combined sheet rngCopy.Copy rngPaste 'enter the location name in column A for all copied entries wsNew.Range(rngPaste, rngPaste.End(xlDown)).Offset(0, -1) = Location Next j End Sub