Sub CombineAllOpenWorkbooks()
' Macro written by Barrie Davidson
Dim NewFileName As String
Dim c As Integer
Dim SheetCount As Integer

    NewFileName = ActiveWorkbook.Name
    c =  1 
    Do Until c =  0 
        If Windows(c).Visible = True Then
            Windows(c).Activate
            MsgBox ("New file to be created")
            NewFileName = Application.GetSaveAsFilename _
                (, "Microsoft Excel Workbook (*.xls),*.xls")
            ActiveWorkbook.SaveAs FileName:=NewFileName, _
                FileFormat:=xlWorkbookNormal
            NewFileName = ActiveWorkbook.Name
            ActiveSheet.Select
            c =  0 
            SheetCount = ActiveWorkbook.Sheets.Count
        Else
            c = c +  1 
        End If
    Loop
    For c =  1  To Workbooks.Count
        If Windows(c).Parent.Name <> NewFileName And Windows(c).Visible = True Then
            Windows(c).Activate
            ActiveWorkbook.Sheets.Copy after:=Workbooks(NewFileName).Sheets(SheetCount)
        End If
    Next c
    
End Sub

Sub MultiSheetPrint()
' prints the selected area on each of a set of selected worksheets on 
' a single sheet
  Dim oActive As Object
  Dim oSheet As Object
  Dim oSheets As Object
  Dim wsPrint As Worksheet
  Dim oLastPic As Object
  Dim iPics As Integer
  ' remember where we are
  Set oSheets = ActiveWindow.SelectedSheets
  If oSheets.Count =  1  Then
    Selection.PrintOut preview:=True
    Exit Sub
  End If
  Set oActive = ActiveSheet
  Application.ScreenUpdating = False
  oActive.Select ' otherwise we get lots of new sheets
  Set wsPrint = Worksheets.Add
  For Each oSheet In oSheets
    If TypeName(oSheet) = "Worksheet" Then
      iPics = iPics +  1 
      oSheet.Activate
      Selection.CopyPicture
      wsPrint.Cells(iPics *  3  -  2 ,  1 ).Value = oSheet.Name
      wsPrint.Paste wsPrint.Cells(iPics *  3  -  1 ,  1 )
      wsPrint.Rows(iPics *  3  -  1 ).RowHeight = _
            wsPrint.Pictures(iPics).Height
    End If
  Next
  wsPrint.PrintOut preview:=True
  Application.DisplayAlerts = False
  wsPrint.Delete
  Application.DisplayAlerts = True
  oSheets.Select
  oActive.Activate
  Application.ScreenUpdating = True
End Sub

Sub Combine()
    Dim J As Integer
    
    On Error Resume Next
    Sheets( 1 ).Select
    Worksheets.Add ' add a sheet in first place
    Sheets( 1 ).Name = "Combined"

    ' copy headings
    Sheets( 2 ).Activate
    Range("A1").EntireRow.Select
    Selection.Copy Destination:=Sheets( 1 ).Range("A1")

    ' work through sheets
    For J =  2  To Sheets.Count ' from sheet 2 to last sheet
        Sheets(J).Activate ' make the sheet active
        Range("A1").Select
        Selection.CurrentRegion.Select ' select all cells in this sheets

        ' select all lines except title
        Selection.Offset( 1 ,  0 ).Resize(Selection.Rows.Count -  1 ).Select

        ' copy cells selected in the new sheet on last line
        Selection.Copy Destination:=Sheets( 1 ).Range("A65536").End(xlUp)( 2 )
    Next
End Sub