Custom VBA Functions
- Details
Custom 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
