snippets/microsoft/ms-office/excel/macros/combine_sheets.vba

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