VBA code to copy Excel Worksheets to single Worksheet, and then save to new Excel file.

I need to copy Excel Worksheets to a single Worksheet, and then save the new Worksheet as it's own file - without the VBA code in place.  I have written the following code, but it has two errors that I can easily see.  First, it loops - the Excel file never allows closure.  Second, the single Worksheet file contains no data.  The file is attached, and the code is as follows:

Private Sub Workbook_BeforeClose(Cancel As Boolean)

  Dim ws As Worksheet
  Dim r As Long
 
  Application.ScreenUpdating = False
 
  'Delete contents of Master sheet - row 2 downwards (clear from the previous Save action)
  Worksheets("MASTER").Activate
 
  With ActiveSheet.UsedRange
  .Offset(1, 0).Resize(.Rows.Count - 1).Select
  End With
 
  'Loop through all Worksheets
  For Each ws In ActiveWorkbook.Worksheets
      If ws.Name <> ActiveSheet.Name And ws.Name <> "Data" Then
      'Copy starting at 2nd Row
      ws.UsedRange.Offset(2, 0).Copy
      'Paste data to Master Worksheet, below last used row
      Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1).PasteSpecial xlPasteValues
    End If
  Next ws
 
  'Remove any blank rows
  For r = ActiveSheet.UsedRange.Rows.Count To 2 Step -1
    If Application.WorksheetFunction.CountA(Rows(r)) = 0 Then
      Rows(r).Delete
    End If
  Next r
 
  Application.DisplayAlerts = False
 
  'Write Worksheet to external file - do not include any VBA Code or Macros
  Range("A1").Select
  ActiveWorkbook.Save
      Sheets("Master").Select
    Range("A1:R1245").Select
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ChDir "Y:\Projects"
    ActiveWorkbook.SaveAs Filename:= _
        "Y:\Projects\data.xls", FileFormat:= _
        xlExcel8, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
        , CreateBackup:=False
 
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
 
End Sub
ProjectSchedule.xlsm