I'm trying to create a simple way for current & future (non VBA literate) employees to accomplish some of the tasks I've struggled with. The first being Parsing cells containing Line Feed Characters.
When reports are produced from Workday, sometimes they have to be produced for each item separately, and you end up with a folder like this -
Within each book is a sheet of the same name, but cut off at 31 characters (the maximum for sheet names).
I'd like to enable the user to simply select the folder containing the books and consolidate, rename and alphabetize the sheets.
All in the same module (the CONST) used later, main sub:
Option Explicit Public Const COMPUTER As String = "C:\" Public Sub CombineWorkbooks() Dim myPath As String myPath = UserInputDirectory(COMPUTER) If myPath = vbNullString Then MsgBox "You cancelled the operation", vbCritical Exit Sub End If Application.DisplayAlerts = False Application.EnableEvents = False Application.ScreenUpdating = False Dim destinationWorkbook As Workbook Set destinationWorkbook = Workbooks.Add destinationWorkbook.Sheets("Sheet2").Delete destinationWorkbook.Sheets("Sheet3").Delete Dim sourceWorkbook As Workbook Dim sourceWorksheet As Worksheet Dim strFilename As String strFilename = Dir(myPath & "\*.xls", vbNormal) If Len(strFilename) = 0 Then Exit Sub Do Until strFilename = "" Set sourceWorkbook = Workbooks.Open(Filename:=myPath & "\" & strFilename) Set sourceWorksheet = sourceWorkbook.Worksheets(1) RenameSheet sourceWorksheet sourceWorksheet.Copy After:=destinationWorkbook.Worksheets(destinationWorkbook.Worksheets.Count) sourceWorkbook.Close False strFilename = Dir() Loop destinationWorkbook.Sheets("Sheet1").Delete Application.DisplayAlerts = True Application.EnableEvents = True AlphebetizeSheets destinationWorkbook End Sub
And the supporting cast
Private Sub AlphebetizeSheets(ByVal myBook As Workbook) Dim i As Long Dim j As Long For i = 1 To myBook.Worksheets.Count For j = i To myBook.Worksheets.Count If UCase(myBook.Sheets(j).Name) < UCase(myBook.Sheets(i).Name) Then myBook.Sheets(j).Move before:=Sheets(i) End If Next Next Application.ScreenUpdating = True Application.GetSaveAsFilename End Sub Private Sub RenameSheet(ByVal targetSheet As Worksheet) Dim myParser As Long Dim newName As String myParser = InStr(1, targetSheet.Name, "(") If myParser > 0 Then newName = Trim(Left(targetSheet.Name, myParser - 1)) targetSheet.Name = newName End If End Sub Private Function UserInputDirectory(ByVal baseDirectory As String) As String Dim userFolder As FileDialog Dim directoryName As String MsgBox "Please select the folder the workbooks are in" Set userFolder = Application.FileDialog(msoFileDialogFolderPicker) With userFolder .Title = "Select a Folder" .AllowMultiSelect = False .InitialFileName = baseDirectory If .Show <> -1 Then GoTo FolderPicked directoryName = .SelectedItems(1) End With FolderPicked: UserInputDirectory = directoryName Set userFolder = Nothing End Function
I'm sort of worried that there's too much going on in the
CombineWorkbooks() sub and that I've missed some errors that may need to be handled.