Custom Pre-Made VBA Functions

This section will allow you to speed up your VBA code by using pre-made functions to be inserted into a module within your VBA project.

Function WriteToFile(FileName As String, Data As String, Optional Path As String)
'Overview
'This module can be used to write data to a file. If you do not specify a path
'where the output file is to be located the path of the file which the module is
'contained will be used.
	On Error Resume Next
	Dim WB As Workbook
	Set WB = ThisWorkbook
	'If no path is specified we will assign one.
	 
	 If IsMissing(Path) Then
		Path = WB.Path
		Path = Path & ""
	End If
	FileName = Path & FileName
	Dim fnum As Integer
	fnum = FreeFile ' Get the next free filenumber
	Open FileName For Append As #fnum 'Open the file for Append
	Print #fnum, Data & vbLf 'Write the data and add a linefeed.
	Close #fnum
End Function

—

Function LoadFile(FileName As String, Wsheet As String)
'Overview: This module can be used to load a text file file into Excel and write the output to a worksheet
On Error Resume Next
Dim WB As Workbook
Set WB = ThisWorkbook
Dim WS As Worksheet
Set WS = WB.Worksheets(Wsheet)
Dim Data As String
Dim ProcessData() As String
Dim A As Long
Dim fnum As Integer
fnum = FreeFile
If fnum > 0 Then
	Open FileName For Input As #fnum 'Open the file for Append
	Data = Input$(LOF(1), 1)
	ProcessData() = Split(Data, vbLf) 'Process the data into the array using the linefeed to seperate the lines
	Close #fnum
End If
For A = 1 To 65000
	WS.Cells(A, 1).Value = ProcessData(A - 1)
Next
End Function

—

Function PopulateWSArray(ByRef tmpArray() As String, Wsheet As String, StartRow As Long, StartColumn As Long, EndRow As Long, EndColumn As Long)
On Error Resume Next
'Overview: We can use this module to populate an array that emualtes a worksheet.
'It would allow us easy access to read and process data
Dim WSArray() As Variant 'The array to hold the data
Dim Row, Column As Long
Dim WB As Workbook
Dim WS As Worksheet
Dim A, B As Long 'The counters to use to populate the array
Set WB = ThisWorkbook
Set WS = WB.Worksheets(Wsheet)
Row = EndRow - StartRow
Column = EndColumn - StartColumn
ReDim WSArray(Row, Column)
For A = 1 To Row
	For B = 1 To Column
		WSArray(A, B) = WS.Cells(A, B)
	Next
Next
End Function

—

Function DeleteRows(Column As Long, Wsheet As String)
On Error Resume Next
Dim WB As Workbook
Dim WS As Worksheet
Dim A As Long
Dim tmpValue As Variant
Set WB = ThisWorkbook
Set WS = WB.Worksheets(Wsheet)
For A = 1 To 1000
	tmpValue = WS.Cells(A, Column).Value
	If Len(Trim(tmpValue)) = 0 Then 'The cell does not contain any data
		WS.Cells(A, Column).Activate
		ActiveCell.EntireRow.Delete
		If A > 1 Then
			A = A - 1 'As we delete a row we need to reduce the counter
		End If
	End If
Next
End Function

—

Function TrimAllCells(Wsheet As String)
On Error Resume Next

'This module can be used to remove all leading and trailing spaces from cells ona worksheet

Dim A, B As Long
Dim tmpValue As Variant
Dim WB As Workbook
Dim WS As Worksheet

Set WB = ThisWorkbook
Set WS = WB.Worksheets(Wsheet)

For A = 1 To 10000 'Scroll through 10000 rows
	For B = 1 To 256 'Scroll through columns
		tmpValue = WS.Cells(A, B).Value
		WS.Cells(A, B).Value = Trim(tmpValue)
	Next
Next

End Function

—

Function ListSheets()

On Error Resume Next
'Overview: This module lists all the worksheets in a workbook

Dim WB As Workbook
Dim WS As Worksheet

Set WB = ThisWorkbook

For Each WS In WB.Worksheets
	Debug.Print WS.Name 'This commands write the output to the debugging window (immediate)
Next
End Function

—

Function FindClearDuplicates(WKSheet As String, ColumnsToCheck() As Long, ClearDuplicates As Boolean, OutPutColumn As Long, Optional MatchValue = 90)

On Error Resume Next
'Overview: This module is used to identify duplicate records and associate the duplicate record with its original record
'The module can also find an exact duplicate or you can define the level of precision you want the match to be performed on

Dim WB As Workbook
Dim WS As Worksheet
Dim A, B, C, D, E, X As Long
Dim Counter As Long
Dim Length As Long
Dim Product, Max As Long
Dim inPos, TrueLength As Long

Set WB = ThisWorkbook
Dim tmpValue1, tmpValue2, tmpValue3, tmpValue4, tmpValueCombined, checkValue As Variant

Set WS = WB.Worksheets(WKSheet)
Dim RowOutput As Long
Dim tmpDupes() As Variant

For A = 1 To 10000
	For B = 1 To UBound(ColumnsToCheck)
		tmpValueCombined = tmpValueCombined & Trim(WS.Cells(A, ColumnsToCheck(B)))
	Next
	If Len(tmpValueCombined) > 0 Then
		ReDim Preserve tmpDupes(A)
		tmpDupes(A) = tmpValueCombined
		tmpValueCombined = ""
	Else
		Exit For
	End If
Next

Counter = 1
For A = 1 To UBound(tmpDupes)
	If IsEmpty(WS.Cells(A, OutPutColumn).Value) Then
		tmpValue1 = tmpDupes(A)
		'Check if this was already
	
		For B = (A + 1) To UBound(tmpDupes)
			tmpValue2 = tmpDupes(B)
			
			If ClearDuplicates = True Then 'check for clear duplicates
				If tmpValue1 = tmpValue2 Then
					If Len(WS.Cells(B, OutPutColumn).Value) > 0 Then
					Else
						WS.Cells(B, OutPutColumn).Value = Counter
					End If
				End If
			Else
				If A = 13 Then
					Debug.Print "test"
				End If
			
				Length = Len(tmpValue1)
				For D = 1 To Length
					'Determine True length
					TrueLength = Length - D + 1
				
					For E = 1 To TrueLength
						tmpValue3 = Mid(tmpValue1, D, E)
						inPos = InStr(tmpValue2, tmpValue3)
					
						If inPos > 0 Then
							Product = E
							If Product > Max Then
								Max = Product
							End If	
						End If
					Next
				Next

				If Max = Length Then
					If Len(WS.Cells(B, OutPutColumn).Value) > 0 Then
					Else
						WS.Cells(B, OutPutColumn).Value = Counter
					End If
					
					ElseIf Max >= Length * MatchValue / 100 Then
						If Len(WS.Cells(B, OutPutColumn).Value) > 0 Then
						Else
							WS.Cells(B, OutPutColumn).Value = Counter & "*" & " " & (Max / Length * 100) & "%"
						End If
					End If
					Max = 0
				End If
		Next
		
		WS.Cells(A, OutPutColumn).Value = Counter
		Counter = Counter + 1
	End If
Next
End Function

—

Function ListAppVersion()

On Error Resume Next
'Overview: You can use this module to determine the version of Excel you are running

If Application.Version = "8.0" Then'Excel 2003
	Debug.Print 97
ElseIf Application.Version = "9.0" Then'Excel 2003
	Debug.Print 2000
ElseIf Application.Version = "10.0" Then'Excel 2002
	Debug.Print 2002
ElseIf Application.Version = "11.0" Then'Excel 2003
	Debug.Print 2003
ElseIf Application.Version > "11.0" Then'Excel 2007 and up
	Debug.Print 2007
End If
End Function

—

Function HideSheet(Wsheet As String)

On Error Resume Next
On Error GoTo ErrHandler:
'Overview: Hide a specific worksheet so that a normal user can't unhide it

Dim WB As Workbook
Set WB = ThisWorkbook
WB.Worksheets(Wsheet).Visible = xlSheetVeryHidden
End Function

—

Function EvaluateNumber(Data As String) As Long
On Error Resume Next
'Overview: This module receives a value and converts it to a number. If the value cannot be converted
'the module returns a 0

Dim tmpValue As Variant
tmpValue = CLng(Data)

If IsEmpty(tmpValue) Then
	tmpValue = 0
End If

EvaluateNumber = tmpValue
End Function