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