VBA Code


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