Copying and separating data by Excel Field

Question

I created this code that's meant to pull a specific report that's been saved in a folder clean up (delete) the data and add new titles, divide the information up by one of the fields, then copy the info to a new sheet with the name of the sheet being that field on a scalable and variable basis. The report can vary from being 10x20 to being 900x20 depending, and the field itself is a constantly changing value (it's people at a company, turnover happens).

I've removed some of the more sensitive information. As a note, I'm trying to use a lot of what was told to me in a previous question by @Mat'sMug, so if there's any practices I'm missing, please let me know.

Option Explicit
Function SheetExists(sheetName As String, Optional Workbook As Workbook) As Boolean
    Dim sheet As Worksheet
' Checks if the workbook name exists in existing sheets.
     If Workbook Is Nothing Then Set Workbook = ThisWorkbook
     On Error Resume Next
     Set sheet = Workbook.Sheets(sheetName)
     On Error GoTo 0
     SheetExists = Not sheet Is Nothing
 End Function
Sub PO_Create()
' Initializes variables.
Dim lastRow As Integer
Dim lastCol As Integer
Dim weekStart As String
Dim dirFile As String
Dim terrName As String
Dim passProc As String
Dim wbClear As Object
Dim titleCol As Integer
Dim terrRow As Integer
Dim headers As Range
Dim dataRow As Integer
Dim newLine As Integer
Dim fileSave As String
Dim Infobox As Object

' Asks for the password to run the macro.
passProc = InputBox("Please enter the password to refresh the report.", _
    "Password Protected")
If passProc <> "Analyst!" Then
    MsgBox "Invalid password.", vbOKOnly
    Exit Sub
End If

' Turn off the screen and checks if the related file exists.
Application.ScreenUpdating = False
weekStart = Format(Admin.Cells(2, 3).Value, "mm-dd-yyyy")
dirFile = "C:\FileLocation " & _
    weekStart & ".xls"
If Dir(dirFile) = "" Then
    MsgBox "That file date was not found, please try a different date or rerun the report.", vbOKOnly
    Exit Sub
End If
Application.DisplayAlerts = False

' Clears all old data and sheets.
POList.Cells.ClearContents
For Each wbClear In ThisWorkbook.Worksheets
    If wbClear.Name <> "PO List" And wbClear.Name <> "Administration" Then
       wbClear.Delete
    End If
Next wbClear
Application.DisplayAlerts = True

' Opens the related workbook and trims unnecessary data.
Workbooks.Open (dirFile)
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
For titleCol = lastCol To 1 Step -1
    If Cells(1, titleCol).Value <> "1" And _
        Cells(1, titleCol).Value <> "2" And _
        Cells(1, titleCol).Value <> "3" And _
        Cells(1, titleCol).Value <> "4" And _
        Cells(1, titleCol).Value <> "5" And _
        Cells(1, titleCol).Value <> "6" And _
        Cells(1, titleCol).Value <> "7" And _
        Cells(1, titleCol).Value <> "8" And _
        Cells(1, titleCol).Value <> "9" And _
        Cells(1, titleCol).Value <> "10" Then
    Columns(titleCol).EntireColumn.Delete
    End If
Next titleCol

' Reinitializes the last cells.
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column

' Copies and pastes the PO list information to the workbook.
ActiveSheet.Range(Cells(1, 1), Cells(lastRow, lastCol)).Copy
ThisWorkbook.Sheets("PO List").Activate
Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
POList.Range(Cells(1, 8), Cells(lastRow, 9)).Cut
Range(Cells(1, 1), Cells(lastRow, 2)).Insert (xlToRight)
Application.CutCopyMode = False
Selection.Columns.AutoFit

' Closes the PO list and focuses the window on the Report runner.
Workbooks("po list " & weekStart & ".xls").Activate
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
ThisWorkbook.Activate

' Renames column names.
Cells(1, 1).Value = "Territory"
Cells(1, 2).Value = "Name"
Cells(1, 3).Value = "PO Number"
Cells(1, 4).Value = "Vendor"
Cells(1, 5).Value = "Buyer"
Cells(1, 6).Value = "Order Date"
Cells(1, 7).Value = "Request Date"
Cells(1, 8).Value = "Job Number"
Cells(1, 9).Value = "Job Name"
Cells(1, 10).Value = "Job Task"

' Reinitializes the last cells.
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column

' Converts the numbers stored as text to numbers.
POList.Columns("A:A").Insert (xlShiftToRight)
For terrRow = 2 To lastRow
    Cells(terrRow, 1).Value = "=B" & terrRow & "*1"
Next terrRow
Range(Cells(2, 1), Cells(lastRow, 1)).Copy
Cells(2, 2).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Cells(1, 1).EntireColumn.Delete (xlShiftToLeft)

' Reinitializes the last cells.
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column

' Loops through each line and sorts it to either a new sheet, or to an existing sheet.
Set headers = POList.Range(Cells(1, 1), Cells(1, lastCol))
For dataRow = 2 To lastRow
    terrName = Format(POList.Cells(dataRow, 1).Value)
    If SheetExists(terrName) Then
        ' Go to the end of that sheet and copy/paste the information.
        POList.Select
        Range(Cells(dataRow, 1), Cells(dataRow, lastCol)).Copy
        Sheets(terrName).Select
        newLine = Cells(Rows.Count, 1).End(xlUp).Row + 1
        Cells(newLine, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        Columns.AutoFit
        POList.Select
    Else
        ' Create a new sheet, add headers, and copy the line.
        Sheets.Add.Name = terrName
        ActiveSheet.Tab.Color = 108
        headers.Copy
        Sheets(terrName).Select
        Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        POList.Select
        Range(Cells(dataRow, 1), Cells(dataRow, lastCol)).Copy
        Sheets(terrName).Select
        newLine = Cells(Rows.Count, 1).End(xlUp).Row + 1
        Cells(newLine, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        Columns.AutoFit
        POList.Select
    End If
Next dataRow
' Save the worksheet with a new name and resets the workbook display properties.
Application.DisplayAlerts = False
fileSave = "C:\NewFileLocation " & _
    weekStart & " to " & Format(Admin.Cells(2, 3).Value + 4, "mm-dd-yyyy") & ".xlsm"
ThisWorkbook.SaveAs (fileSave)
Application.DisplayAlerts = True
Application.ScreenUpdating = True

Exit Sub
' This is where the code will go if an error occurs
Errhandler:
Set Infobox = CreateObject("Wscript.Shell")
Select Case Infobox.Popup( _
    "The code has encountered an error and needs to close." & _
    vbCrLf & vbCrLf & "Please contact the Financial Analyst with the error" 
    & vbCrLf & _
    "below." & vbCrLf & vbCrLf & _
    "Number: #" & Err.Number & vbCrLf & _
    "Error Description: " & vbCrLf & Err.Description & vbCrLf & vbCrLf & _
    "Press OK or wait 5 seconds to close this.", 5, "Error!", 1)
    Case 1, -1
        Exit Sub
End Select
End Sub

Is there a better way to do this that still allows for expansion?

Answer 1

Declaring your variables right before using them will help you remember what they're for. At the top you have a large block of declarations before you get to your code. Moving them to where they get used will make it a little easier to read.

If you have a number in your code, what does it represent? 108 exists and it represents something but what? Use a Const and give that number an appropriate name. The same is true for 5 with the Infobox. This helps to self document your code.

Where you have a comment that explains what happens that's a good bet you can refactor that portion of code into its own Sub/Function. The comment ' Renames column names. can become RenameColumns and you'll provide it with the worksheet yo uwant to work with. Call site, where it's used, looks like RenameColumns POList. You know now exactly what's occurring. The code itself should self document, it should tell you what's happening. Comments, if they're even needed, explain why it's done in the chosen manner.

Private Sub RenameColumns(ByVal renameSheet As Worksheet)
    With renameSheet 'Value2 is slightly faster and doesn't have rounding issues
        .Cells(1, 1).Value2 = "Territory"
        .Cells(1, 2).Value2 = "Name"
        .Cells(1, 3).Value2 = "PO Number"
        .Cells(1, 4).Value2 = "Vendor"
        .Cells(1, 5).Value2 = "Buyer"
        .Cells(1, 6).Value2 = "Order Date"
        .Cells(1, 7).Value2 = "Request Date"
        .Cells(1, 8).Value2 = "Job Number"
        .Cells(1, 9).Value2 = "Job Name"
        .Cells(1, 10).Value2 = "Job Task"
    End With
End Sub

The cells are now qualified with a sheet name and are not implicitly referring to an ActiveSheet. Implicit ranges cause headaches because they are easy to miss. Fully qualify them with a variable that represents a worksheet. worksheetVariable.Cells lets you know without a doubt which worksheet it's referring to.

Your code that follows' Turn off the screen and checks if the related file exists. is hiding a possible issue. You'll hit the Exit Sub and ScreenUpdating won't be turned back on. Only turn ScreenUpdating off if your guard clauses have been passed and you're confident your code can run.

Your first refactored method from ' Clears all old data and sheets. is ClearOldDataAndSheets. The name of the method describes what it's doing and makes clear what will occur. Naming is hard and it takes time to come up with concise names. I'd suggest using the CodeName property rather than Name. CodeName won't cause issues if a tab is renamed in Excel. In the IDE F4 is the same as View>Properties Window and will let you rename a worksheet. (Name) is the CodeName and Name = TabName. You can see this in the project explorer which has it shown as CodeName (Name).

Private Sub ClearOldDataAndSheets()
    Application.DisplayAlerts = False

    Dim wbClear As Worksheet
    ' Clears all old data and sheets.
    POList.Cells.ClearContents
    For Each wbClear In ThisWorkbook.Worksheets
        If wbClear.Name <> "PO List" And wbClear.Name <> "Administration" Then
            wbClear.Delete
        End If
    Next wbClear
    Application.DisplayAlerts = True
End Sub

Continuing on with comment replacements ' Opens the related workbook and trims unnecessary data. becomes TrimUnecessaryDataFrom. This is now a function that takes in pathWithFilename and returns a Workbook. I changed the And to be the first item following the line break. With my experience this helps to not forget that it's also part of the boolean condition that's checked. Entirely preferential. This gives you your stripped down workbook.

Private Function TrimUnecessaryDataFrom(ByVal pathWithFilename As String) As Workbook

Dim bookToTrim As Workbook
Set bookToTrim = Workbooks.Open(pathWithFilename)

With bookToTrim.ActiveSheet
    Dim lastCol As Long
    lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column

    Dim titleCol As Long
    For titleCol = lastCol To 1 Step -1
        If .Cells(1, titleCol).Value <> "1" _
            And .Cells(1, titleCol).Value <> "2" _
            And .Cells(1, titleCol).Value <> "3" _
            And .Cells(1, titleCol).Value <> "4" _
            And .Cells(1, titleCol).Value <> "5" _
            And .Cells(1, titleCol).Value <> "6" _
            And .Cells(1, titleCol).Value <> "7" _
            And .Cells(1, titleCol).Value <> "8" _
            And .Cells(1, titleCol).Value <> "9" _
            And .Cells(1, titleCol).Value <> "10" Then

            .Columns(titleCol).EntireColumn.Delete
        End If
    Next titleCol
End With

Set TrimUnecessaryDataFrom = bookToTrim
End Function

Next is ' Copies and pastes the PO list information to the workbook. which becomes CopyPOInfoFrom. You have a .Copy with .Activate (note that .Select is the same) followed by an implicitly referencing Cells. Needlessly Activateing can be avoided by fully qualifying a range reference with the Worksheet it's on.

Private Sub CopyPOInfoFrom(ByVal copyFromSheet As Worksheet)
' Reinitializes the last cells.
    Dim lastRow As Long
    Dim lastCol As Long
    lastRow = copyFromSheet.Cells(Rows.Count, 1).End(xlUp).Row
    lastCol = copyFromSheet.Cells(1, Columns.Count).End(xlToLeft).Column

    ' Copies and pastes the PO list information to the workbook.
    copyFromSheet.Range(copyFromSheet.Cells(1, 1), copyFromSheet.Cells(lastRow, lastCol)).Copy
    POList.Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats

    Application.CutCopyMode = False
    Dim cutRange As Range
    Set cutRange = POList.Range(POList.Cells(1, 8), POList.Cells(lastRow, 9))
    cutRange.Cut
    POList.Cells(1, 1).Resize(cutRange.Rows.Count, cutRange.Columns.Count).Insert xlToRight
    Application.CutCopyMode = False
    Selection.Columns.AutoFit
End Sub

Once that sub is finished you have the information moved over. RenameColumns follows and that's been explained.

' Converts the numbers stored as text to numbers. becomes ConvertsNumbersStoredAsTextToNumbers and you supply the argument for the sheet you want to work with. A few helper variables were created to simplify the logic of what you're working with.

Private Sub ConvertsNumbersStoredAsTextToNumbers(ByVal sheetToWorkWith As Worksheet)
    With sheetToWorkWith
        Dim lastRow As Long
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row

        Dim textNumbers As Range
        Set textNumbers = .Range(.Cells(2, 1), .Cells(lastRow, 1))
        sheetToWorkWith.Columns("A:A").Insert xlShiftToRight

        Dim numberRange As Range
        Set numberRange = sheetToWorkWith.Cells(2, 1).Resize(textNumbers.Rows.Count)
        numberRange.Formula = "=" & textNumbers.Cells(1, 1).Address(False, False) & "*1"
        numberRange.Copy
        textNumbers.PasteSpecial xlPasteValuesAndNumberFormats

        .Columns(1).Delete xlShiftToLeft
    End With
End Sub

' Loops through each line and sorts it to either a new sheet, or to an existing sheet. becomes MoveInformationToAppropriateLocation. And the same for the saving of the workbook.

Moving Sub

Private Sub MoveInformationToAppropriateLocation(ByVal sheetToWorkWith As Worksheet)
    With sheetToWorkWith
        Dim moveToSheet As Worksheet
        ' Reinitializes the last cells.
        Dim lastRow As Long
        Dim lastCol As Long
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column

        Dim columnSpan As Long
        columnSpan = lastCol
        ' Loops through each line and sorts it to either a new sheet, or to an existing sheet.
        Dim headers As Range
        Set headers = .Cells(1, 1).Resize(ColumnSize:=columnSpan)

        Dim newLine As Long
        Dim dataRow As Long
        For dataRow = 2 To lastRow
            Dim terrName As String
            terrName = Format$(.Cells(dataRow, 1).Value2)
            If SheetExists(terrName) Then
                ' Go to the end of that sheet and copy/paste the information.
                POList.Cells(dataRow, 1).Resize(ColumnSize:=columnSpan).Copy
                Set moveToSheet = Worksheets(terrName)
                newLine = moveToSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
                moveToSheet.Cells(newLine, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            Else
                ' Create a new sheet, add headers, and copy the line.
                Set moveToSheet = ThisWorkbook.Worksheets.Add
                moveToSheet.Name = terrName
                Const MAROON As Long = 108
                moveToSheet.Tab.Color = MAROON
                headers.Copy
                moveToSheet.Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                POList.Cells(dataRow, 1).Resize(ColumnSize:=columnSpan).Copy
                moveToSheet.Cells(1 + headers.Rows.Count, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            End If
        Next dataRow
    End With

    moveToSheet.Columns.AutoFit
End Sub

Saving Sub

Private Sub SaveFileWithName(ByVal saveName As String)
    Application.DisplayAlerts = False
    ThisWorkbook.SaveAs saveName
    Application.DisplayAlerts = True
End Sub

The refactored code is what follows. You no longer are looking at the nitty-gritty that's going on. You have a descriptive name for each part that lets you look only at that Sub-section of code. Each Sub/Function should be doing one thing and that's it. How it's doing it is an implementation detail that you don't need with a general overview. If something isn't correct you can go to that one piece that's not working and fix it. As I commented in the code with TODO that section of code can, and IMO should, become one line with a descriptive name.

Public Sub PO_Create()
    On Error GoTo Errhandler
    ' Asks for the password to run the macro.
    Dim passProc As String
    passProc = InputBox("Please enter the password to refresh the report.", "Password Protected")
    If passProc <> "Analyst!" Then
        MsgBox "Invalid password.", vbOKOnly
        Exit Sub
    End If

    ' Does related file exist?
    Dim weekStart As String
    weekStart = Format$(Admin.Cells(2, 3).Value, "mm-dd-yyyy")
    Dim dirFile As String
    dirFile = "C:\FileLocation " & weekStart & ".xls"
    If Dir(dirFile) = vbNullString Then
        MsgBox "That file date was not found, please try a different date or rerun the report.", vbOKOnly
        Exit Sub
    End If

    Application.ScreenUpdating = False

    'TODO: This can be refactorerd (https://en.wikipedia.org/wiki/Code_refactoring)
    'to have 'CopyPOInfoFrom' to be the only part visible. Everything else will be called
    'from that that leaving one line visible here
    ClearOldDataAndSheets
    Dim POWorkbook As Workbook
    Set POWorkbook = TrimUnecessaryDataFrom(dirFile)
    CopyPOInfoFrom POWorkbook.ActiveSheet
    Application.DisplayAlerts = False
    POWorkbook.Close
    Application.DisplayAlerts = True
    ThisWorkbook.Activate

    RenameColumns POList
    ConvertsNumbersStoredAsTextToNumbers POList
    MoveInformationToAppropriateLocation POList

    Dim fileSave As String
    fileSave = "C:\NewFileLocation " & weekStart & " to " & Format$(Admin.Cells(2, 3).Value + 4, "mm-dd-yyyy") & ".xlsm"
    SaveFileWithName fileSave

    Application.ScreenUpdating = True
    Exit Sub

Errhandler:
    Dim Infobox As Object
    Set Infobox = CreateObject("Wscript.Shell")
    Dim msg As String
    msg = "The code has encountered an error and needs to close." & vbCrLf & vbCrLf & _
           "Please contact the Financial Analyst with the error" & vbCrLf & "below." & vbCrLf & vbCrLf & _
           "Number: #" & Err.Number & vbCrLf & _
           "Error Description: " & vbCrLf & Err.Description & vbCrLf & vbCrLf & _
           "Press OK or wait 5 seconds to close this."
    Const WAIT_TIME_BEFORE_AUTO_CLOSE As Long = 5
    Select Case Infobox.Popup(msg, WAIT_TIME_BEFORE_AUTO_CLOSE, "Error!", 1)
    Case 1, -1
        Exit Sub
    End Select
End Sub

Lastly. I used http://rubberduckvba.com to pick up on the following that I missed. Note: I'm a contributor thanks to @Mat'sMug and it's helped me a lot. For me Rubberduck is an indispensable tool and I regret nothing about it.

• You have the line label Errhandler but it's never set anywhere. On Error GoTo Errhandler
• In your function SheetExists your parameters are passed by reference. I didn't see them set so they can be passed ByVal