Last active
September 20, 2016 01:21
-
-
Save MattPatrickMeyer/d039f4e169c602402726566f8be80372 to your computer and use it in GitHub Desktop.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Private Sub MergeButton_Click() | |
| Dim filename As Variant | |
| Dim wb As Workbook | |
| Dim s As Sheet1 | |
| Dim thisSheet As Sheet1 | |
| Dim lastUsedRow As Range | |
| Dim newBook As Workbook | |
| On Error GoTo ErrMsg | |
| Application.ScreenUpdating = False | |
| ' Set thisSheet = ThisWorkbook.ActiveSheet | |
| ' Create a new Workbook | |
| Set newBook = WorkBooks.Add | |
| With newBook | |
| .Title = "Whatever" | |
| .Subject = "Whatever" | |
| .SaveAs Filename:="Test.xls" | |
| End With | |
| Set thisSheet = newBook.Worksheets("Sheet1") | |
| For i = 0 To FilesListBox.ListCount - 1 | |
| filename = FilesListBox.List(i, 0) | |
| 'Open the spreadsheet in ReadOnly mode | |
| Set wb = Application.Workbooks.Open(filename, ReadOnly:=True) | |
| 'Copy the used range (i.e. cells with data) from the opened spreadsheet | |
| If FirstRowHeadersCheckBox.Value And i > 0 Then 'Only include headers from the first spreadsheet | |
| Dim mr As Integer | |
| mr = wb.ActiveSheet.UsedRange.Rows.Count | |
| wb.ActiveSheet.UsedRange.Offset(1, 0).Resize(mr - 1).Copy | |
| Else | |
| wb.ActiveSheet.UsedRange.Copy | |
| End If | |
| 'Paste after the last used cell in the master spreadsheet | |
| If Application.Version < "12.0" Then 'Excel 2007 introduced more rows | |
| Set lastUsedRow = thisSheet.Range("A65536").End(xlUp) | |
| Else | |
| Set lastUsedRow = thisSheet.Range("A1048576").End(xlUp) | |
| End If | |
| 'Only offset by 1 if there are current rows with data in them | |
| If thisSheet.UsedRange.Rows.Count > 1 Or Application.CountA(thisSheet.Rows(1)) Then | |
| Set lastUsedRow = lastUsedRow.Offset(1, 0) | |
| End If | |
| lastUsedRow.PasteSpecial | |
| Application.CutCopyMode = False | |
| Next i | |
| newBook.Save | |
| Set wb = Nothing | |
| #If Mac Then | |
| 'Do nothing. Closing workbooks fails on Mac for some reason | |
| #Else | |
| 'Close the workbooks except this one | |
| Dim file As String | |
| For i = 0 To FilesListBox.ListCount - 1 | |
| file = FilesListBox.List(i, 0) | |
| file = Right(file, Len(file) - InStrRev(file, Application.PathSeparator, , 1)) | |
| Workbooks(file).Close SaveChanges:=False | |
| Next i | |
| #End If | |
| Application.ScreenUpdating = True | |
| Unload Me | |
| ErrMsg: | |
| If Err.Number <> 0 Then | |
| MsgBox "There was an error. Please try again. [" & Err.Description & "]" | |
| End If | |
| End Sub |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment