Convert Subroutines to Functions - excel

Question

I posted a question here, regarding using a macro and having a screentip and I received a very good idea from #Tim Williams but in order for this to work I need to convert subs into functions. I have never done that before and I don't know if it is possible but I hope one of you experts can guide me. Here are my subroutines that need to be converted for this to work.
Normal / Editable View - This program is run from full screen mode. So this subroutine allows the user to press a button and go to normal excel view.
```
Sub ScreenDisplayNorm()
Call UnProtectAllSheets
With Application
.DisplayFullScreen = False
With ActiveWindow
.WindowState = xlNormal
.DisplayHeadings = True
.DisplayWorkbookTabs = True
.DisplayGridlines = False
.DisplayHorizontalScrollBar = True
.DisplayVerticalScrollBar = True
.Zoom = 80
End With
.DisplayStatusBar = True
.DisplayFormulaBar = True
End With
End Sub
```
Fullscreen View - Press button to convert view back to fullscreen!
```
Sub GotoResources()
Set wbPB = PokerBros
Dim maxWidth As Long
Dim myWidth As Long
Dim Myzoom As Single
Dim wsR As Worksheet: Set wsR = wbPB.Worksheets("Resource Data")
Dim Rng As Range: Set Rng = wsR.Range("A1:U35")
Call UnProtectAllSheets
wsR.Activate
Call EnhancePerformance 'call sub to Improve speed (screen updates and calculations)
Call ScreenDisplayMax 'call sub to maximize
maxWidth = GetSystemMetrics(0) * 0.96 'maximum width measurement
myWidth = ActiveSheet.Range("U1").Left 'Actual width of program starting from the left edge of the cell furthest_
'to the right that fits the best view
Myzoom = maxWidth / myWidth
ActiveWindow.Zoom = Myzoom * 90
Rng.Select
ActiveWindow.Zoom = True 'set range zoom
ActiveSheet.Range("A1").Select
Call NormalPerformance 'call sub to perform normal (screen updates and calculations)
Call ProtectAllSheets
End Sub
```
Save - Button will save current file
```
Sub SaveWorkbook()
ActiveWorkbook.Save
End Sub
```
SaveAs - User can save file to a different location.
```
Sub SaveAsDialogBox()
Dim CarryOn As Boolean
Call UnProtectAllSheets
CarryOn = MsgBox("Do you want to save a copy of this original file?", vbYesNo, "Save Copy Recommended")
If CarryOn = True Then
CopyToNewBook
End If
End Sub
```
Player Profile - Opens player profile userform to gather data.
```
Sub OpenProfileUF()
ufDirectory.Show vbModeless
End Sub
```
Import Data - Allows user to calculate results
```
Sub UpdateArray()
Dim wsDest As Worksheet
Dim arSource() As Variant, arDest() As Variant, varID As Variant, ImportDate As Variant
Dim outputColumns As Variant, inputColumns As Variant
Dim filename As String: filename = "C:\Users\AdamRhodes\OneDrive\Desktop\PokerBros\PokerBrosSuppliment.xlsm"
Dim strDest As String, lastsrcrow As Long, AddRow As Integer, strfilename As String
Dim lrow As Long, CarryOn As Boolean, MsgAnswer As Integer
Set wbPB = PokerBros
Set wsPT = wbPB.Worksheets("Player Tracking")
Call UnProtectAllSheets
Call EnhancePerformance
CarryOn = MsgBox("Running this macro will import" & "," & "extract" & "," & _
"and compute data from other files and will add calculations to some reporting" & "." & "It is recommended to save a copy to restore with confidence" & "." & "If you already saved a copy and wish to proceed select ""Yes"" and select ""No"" to exit and save a copy" & "!", vbYesNo, "Please Approve Data Load")
If CarryOn = vbNo Then
Exit Sub
End If
MsgAnswer = MsgBox("Would you like to select your filepath? If you select ""NO"" The application will attempt to open the file" & ".", vbYesNoCancel + vbQuestion, "Locate File to Export Data!")
If MsgAnswer = vbYes Then
strfilename = Application.GetOpenFilename(Title:="Browse and Select you Newest PokerBrosSuppliment.xls file", FileFilter:="Excel Files (*.xls*),*xls*")
Set wbSource = Application.Workbooks.Open(filename:=strfilename, ReadOnly:=True)
ElseIf MsgAnswer = vbNo Then
On Error Resume Next 'Call function to check if the file is open
If IsFileOpen(filename) = False Then 'Insert actions to be performed on the closed file
Set wbSource = Application.Workbooks.Open(filename:=filename, ReadOnly:=True)
Else: MsgBox filename & " is already open." 'The file is open or another error occurred
Set wbSource = Workbooks("PokerBrosSuppliment.xlsm") 'open the file manually
If IsError(Error) Then 'if there is an error opening the file it may already be open.
strfilename = Application.GetOpenFilename(Title:="Browse and Select you Newest PokerBrosSuppliment.xls file", FileFilter:="Excel Files (*.xls*),*xls*")
Set wbSource = Application.Workbooks.Open(filename:=strfilename, ReadOnly:=True)
Else: Set wbSource = Application.Workbooks.Open(filename:=strfilename, ReadOnly:=True)
End If
End If
ElseIf MsgAnswer = vbCancel Then
MsgBox "No file has been selected" & "." & "File has not been imported" & "!", vbOKOnly + vbExclamation, "Procedure was Cancelled"
Exit Sub
End If
On Error GoTo 0
Set wsSource = wbSource.Worksheets("Export")
'use last row from suppliment to determine how many formatted rows needed for player tracking
lastsrcrow = wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row
AddRow = lastsrcrow - rCntr 'rcntr is a constant 150. so the last row minus 150 determines how many formatted rows to be added.
wsPT.Activate ' activate Player Tracking
Call AddNew_Worksheet 'call sub to add new worksheet
strDest = wbPB.Worksheets(ActiveSheet.Name).Name 'rename the new spreadsheet
Set wsDest = wbPB.Worksheets(strDest) 'set the worksheet object
If AddRow > 0 Then 'Add rows if needed
wsDest.Rows(rCntr + 1 & ":" & AddRow + rCntr + 1).Select 'determine how many rows to add
Selection.EntireRow.Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove 'select the range and insert rows
With wsDest
.Range("B150:N150").AutoFill Destination:=Range("B150:N" & AddRow + 151), Type:=xlFillDefault 'autofill from cells above to format
End With
End If
inputColumns = Array(6, 4, 5, 7, 8, 23, 35, 36) 'source array data
outputColumns = Array(2, 3, 4, 5, 6, 7, 12, 13) 'Destination array data
Call writeArray(inputColumns, outputColumns) 'write the array
Call Get_RakeBack_Rates 'call sub to insert Rake Back Rates
Application.DisplayAlerts = False 'hide alert about closing the source file with data on the clipboard
wbSource.Close savechanges:=False 'close workbook
Application.DisplayAlerts = True 'activate alerts again
Call NormalPerformance
Call ProtectAllSheets
End Sub
```
Directory Adds - Adds new accounts to the directory.
```
Sub DirectoryAdds()
Set wbPB = PokerBros
Dim srcColumns As Variant: srcColumns = Array(2, 3, 4, 5, 6, 7, 8, 10, 11, 13, 14)
Dim tgtColumns As Variant: tgtColumns = Array(2, 3, 4, 5, 6, 8, 7, 9, 10, 11, 12)
Dim wsIT As Worksheet: Set wsIT = wbPB.Worksheets(Worksheets.Count)
Dim wsPD As Worksheet: Set wsPD = wbPB.Worksheets("Player Directory")
Dim Rng As Range, rngSource As Range, c As Range
Dim Curr, ub As Long, i As Long, k As Long
Dim wsPDlastrow As Long: wsPDlastrow = wsPD.Cells(Rows.Count, "B").End(xlUp).Row
Dim lastrow As Long, inc As Integer, FillRow As Integer, NextRow As Integer, lastRR As Long
Call UnProtectAllSheets
Call EnhancePerformance
ub = UBound(srcColumns) 'Player Tracking UBound column count
If wsIT Is wsPD Then 'If Player Directory sheet is Activesheet exit sub. Player Tracking needs to be active at start of macro
MsgBox "Wrong sheet selected."
Exit Sub
End If
'set source range from Player Tracking
Set rngSource = wsIT.Range(wsIT.Cells(srcFirstRow, srcColumns(0)), wsIT.Cells(Rows.Count, srcColumns(0)).End(xlUp))
For Each c In rngSource.Cells
If Len(c.Value) > 0 Then
'Simpler to search full column, but assumes there will be no match in the header or the cells above it.
Curr = Application.Match(c.Value, wsPD.Columns(tgtColumns(0)), 0) 'no Worksheetfunction=no runtime error if no match
If Not IsError(Curr) Then 'increment last column
For inc = 5 To 10
If inc > 10 Then Exit For
If inc = 6 Or inc = 7 Then
GoTo SKIP_ITERATION:
End If
With wsPD.Cells(Curr, tgtColumns(inc))
.Value = .Value + wsIT.Cells(c.Row, srcColumns(inc)).Value
End With
SKIP_ITERATION: Next inc
Else
Set Rng = wsPD.Cells(Rows.Count, tgtColumns(0)).End(xlUp).Offset(1, 0) 'no
match: copy over
For k = 0 To ub
wsPD.Cells(Rng.Row, tgtColumns(k)).Value = wsIT.Cells(c.Row, srcColumns(k)).Value
Next k
End If
End If
lastrow = wsPD.Range("B" & Rows.Count).End(xlUp).Row
With wsPD.Cells(lastrow + 1, 2)
.EntireRow.Copy
.EntireRow.Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove
End With
Application.CutCopyMode = False
Next c
For Each c In wsPD.Range("B4:M" & lastrow) 'locate all blank rows in player details cells
If IsEmpty(c) Then
c.Value = "None" 'Put "TBD" in all blank cells
End If
Next c
MsgBox "Operation finished successfully."
Call NormalPerformance
Call ProtectAllSheets
End Sub
```

Answer 1

To convert a Sub to a Function, you simply need to change the definition from Sub xxx to Function xxx, the closing End Sub to End Function and any Exit Sub to Exit Function. That`s all - however it will be rather useless to do so.
None of these functions will return anything, and the basic idea of a function is to return something (in opposite to a sub that cannot return anything - in other programming languages this is called a void function). The question is why you want to convert it to a function and what you want to return?
To let a function return anything, you simply assign a value to the function name. So if you have a function foo, you write:
Function foo
(...)
foo = "Hello world"
end Function
Now, the function will return the string "Hello world". You should declare the type that is returned by the function (else it will return a variant):
Function doubleMe(x as Long) As Long
(...)
doubleMe = x * 2
End Function
and use the result on your code
myVal = doubleMe(12345)
y1 = 555
Debug.Print doubleMe(y1) & " is twice as much as " & y1
If you are not interested in the result you can call the function like any subroutine, either with Call (and use parenthesis for the parameter) or without (then you have to omit the parenthesis)
doubleMe 0
Call doubleMe(-1)
Often you see that a function returns a Boolean indicating the success
Function ToSomethingComplicated(p1, p2, p3) as boolean
ToSomethingComplicated = False
(do your complicated stuff here)
if (something failed) Then Exit Function
(do some more complicated stuff)
(...)
' If everything was successfull, return True
ToSomethingComplicated = True
End Function