Excel VBA Automation Toolkit

Sub InitializeVBAEnvironment()
    ' This macro initializes the VBA environment for Excel projects.

    ' Step 1: Open the Visual Basic for Applications Editor
    ' Navigate to the Developer tab in Excel and click on Visual Basic to open the VBA editor.
    
    ' Step 2: Insert a new module, if needed
    ' Use these commands to programmatically insert a new module if it does not exist.
    Dim VBCodeMod As Object
    Set VBCodeMod = ThisWorkbook.VBProject.VBComponents.Add(1)
    
    ' Step 3: Set up basic error handling structure
    On Error GoTo ErrorHandler

    ' Step 4: Example routine to add a basic subroutine template in the new module
    With VBCodeMod.CodeModule
        .InsertLines .CountOfLines + 1, "Sub HelloWorld()"
        .InsertLines .CountOfLines + 1, "    MsgBox ""Hello, World!"""
        .InsertLines .CountOfLines + 1, "End Sub"
    End With

    Exit Sub

ErrorHandler:
    MsgBox "An error occurred: " & Err.Description
End Sub

' Module: ErrorHandlingTemplates

' Error Handler Template
Sub ErrorHandlerTemplate()
    On Error GoTo ErrorHandler

    ' Main logic here
    ' Example: MsgBox "This is a test message.", vbInformation

    Exit Sub

ErrorHandler:
    Call CustomErrorHandler(Err.Number, Err.Description, "ErrorHandlerTemplate")
    Resume Next
End Sub

' Custom Error Handler Procedure
Sub CustomErrorHandler(ByVal errNumber As Long, ByVal errDescription As String, ByVal subName As String)
    ' Log or display error information
    Dim errorMessage As String
    errorMessage = "Error " & errNumber & vbCrLf & "Description: " & errDescription & vbCrLf & "In Sub: " & subName
    MsgBox errorMessage, vbCritical, "Error Encountered"
    
    ' Optional: Write to log file or database (commented out)
    ' Call LogErrorToFile(errNumber, errDescription, subName)
End Sub

' Example procedure using error handling template
Sub ExampleProcedure()
    On Error GoTo ExampleErrorHandler

    ' Place custom logic here
    ' Example: Dim x As Integer: x = 10 / 0 ' This will cause a divide by zero error

    Exit Sub

ExampleErrorHandler:
    Call CustomErrorHandler(Err.Number, Err.Description, "ExampleProcedure")
    Resume Next
End Sub

' Optional: Additional logging mechanism
' Sub LogErrorToFile(ByVal errNumber As Long, ByVal errDescription As String, ByVal subName As String)
'     ' Logic to append error to a text file or database
'     Dim filePath As String
'     filePath = "C:\Path\ErrorLog.txt"
'     Open filePath For Append As #1
'     Print #1, Now & " - Error " & errNumber & ": " & errDescription & " in " & subName
'     Close #1
' End Sub

' Create a custom function to calculate the percentage increase between two numbers
Function CalculatePercentageIncrease(initialValue As Double, finalValue As Double) As Double
    ' Ensure initialValue is not zero to avoid division by zero error
    If initialValue = 0 Then
        MsgBox "Initial value cannot be zero", vbCritical
        Exit Function
    End If
    
    ' Calculate the percentage increase
    CalculatePercentageIncrease = ((finalValue - initialValue) / initialValue) * 100
End Function

' Create a custom function to concatenate strings with a delimiter
Function ConcatenateWithDelimiter(ParamArray args() As Variant) As String
    Dim delimiter As String
    Dim i As Integer
    Dim result As String
    
    ' Define the delimiter (modification as needed)
    delimiter = ", " 
    
    ' Iterate through each argument
    For i = LBound(args) To UBound(args)
        If i = LBound(args) Then
            result = args(i)
        Else
            result = result & delimiter & args(i)
        End If
    Next i
    
    ' Assign Concatenated result
    ConcatenateWithDelimiter = result
End Function

' Create a custom function to find the maximum value in a range
Function FindMaxValue(rng As Range) As Double
    Dim cell As Range
    Dim maxValue As Double
    
    ' Initialize maxValue with the first cell's value
    maxValue = rng.Cells(1, 1).Value
    
    ' Iterate over the range to identify the maximum value
    For Each cell In rng
        If cell.Value > maxValue Then
            maxValue = cell.Value
        End If
    Next cell
    
    ' Return the maximum value found
    FindMaxValue = maxValue
End Function

' Define a Subroutine to create a user input form
Sub CreateUserInputForm()
    ' Declare variables
    Dim userForm As Object
    Dim txtBox As MSForms.TextBox
    Dim lbl As MSForms.Label
    Dim btnSubmit As MSForms.CommandButton
    
    ' Create a new UserForm
    Set userForm = VBA.UserForms.Add("MyCustomForm")
    
    ' Create a Label
    Set lbl = userForm.Controls.Add("Forms.Label.1", "lblPrompt", True)
    lbl.Caption = "Enter your data:"
    lbl.Top = 20
    lbl.Left = 20
    
    ' Create a TextBox
    Set txtBox = userForm.Controls.Add("Forms.TextBox.1", "txtInput", True)
    txtBox.Top = lbl.Top + lbl.Height + 10
    txtBox.Left = lbl.Left
    txtBox.Width = 200
    
    ' Create a Submit Button
    Set btnSubmit = userForm.Controls.Add("Forms.CommandButton.1", "btnSubmit", True)
    btnSubmit.Caption = "Submit"
    btnSubmit.Top = txtBox.Top + txtBox.Height + 10
    btnSubmit.Left = txtBox.Left
    btnSubmit.Width = 100
    
    ' Assign a macro to the Submit Button to handle the click event
    btnSubmit.OnAction = "HandleSubmit"
    
    ' Show the user form
    userForm.Show
End Sub

' Define a Subroutine to handle the submit button click event
Sub HandleSubmit()
    Dim userInput As String
    userInput = UserForms("MyCustomForm").Controls("txtInput").Text
    
    ' Perform an action with the user input (e.g., store it in a cell)
    Worksheets("Sheet1").Range("A1").Value = userInput
    
    ' Optionally hide the form after submitting
    UserForms("MyCustomForm").Hide
End Sub

' Dynamic Range Selection Functions in VBA

' Function to select a range based on start row, end row, start column, and end column
Function SelectDynamicRange(ws As Worksheet, startRow As Long, endRow As Long, startCol As Long, endCol As Long) As Range
    Set SelectDynamicRange = ws.Range(ws.Cells(startRow, startCol), ws.Cells(endRow, endCol))
End Function

' Function to select a range dynamically based on column headers
Function SelectRangeByColumnHeaders(ws As Worksheet, header1 As String, header2 As String) As Range
    Dim rng As Range
    Dim cell1 As Range
    Dim cell2 As Range
    
    On Error Resume Next
    Set cell1 = ws.Rows(1).Find(header1, LookIn:=xlValues, LookAt:=xlWhole)
    Set cell2 = ws.Rows(1).Find(header2, LookIn:=xlValues, LookAt:=xlWhole)
    On Error GoTo 0
    
    If Not cell1 Is Nothing And Not cell2 Is Nothing Then
        Set rng = ws.Range(cell1.Offset(1, 0), cell2.Offset(ws.Cells(ws.Rows.Count, cell2.Column).End(xlUp).Row - 1, 0))
    End If
    
    Set SelectRangeByColumnHeaders = rng
End Function

' Example of selecting a range by coordinates
Sub ExampleUseDynamicRange()
    Dim ws As Worksheet
    Dim selectedRange As Range
    
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    ' Select range using coordinates
    Set selectedRange = SelectDynamicRange(ws, 2, 10, 1, 5)
    selectedRange.Select
End Sub

' Example of selecting a range by column headers
Sub ExampleUseColumnHeaders()
    Dim ws As Worksheet
    Dim selectedRange As Range
    
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    ' Select range using column headers 'Header1' and 'Header2'
    Set selectedRange = SelectRangeByColumnHeaders(ws, "Header1", "Header2")
    If Not selectedRange Is Nothing Then selectedRange.Select
End Sub

' Module: DataIOAutomation

' Function to Import Data from a CSV File into Excel
Sub ImportData()
    Dim ws As Worksheet
    Dim filePath As String
    Dim lastRow As Long
    
    ' Set the worksheet where data will be imported
    Set ws = ThisWorkbook.Sheets("DataSheet")
    
    ' Path to the CSV file
    filePath = "C:\Path\To\Your\File.csv"
    
    ' Clear existing data
    ws.Cells.Clear
    
    ' Import the CSV file
    With ws.QueryTables.Add(Connection:="TEXT;" & filePath, Destination:=ws.Range("A1"))
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFilePlatform = xlWindows
        .Refresh BackgroundQuery:=False
    End With
    
    ' Optional: Identify last row of imported data
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    MsgBox "Data Import Completed. Last Row: " & lastRow
End Sub

' Function to Export Data from Excel to a CSV File
Sub ExportData()
    Dim ws As Worksheet
    Dim filePath As String
    Dim lastRow As Long
    Dim lastCol As Long
    
    ' Set the worksheet where data will be exported
    Set ws = ThisWorkbook.Sheets("DataSheet")
    
    ' Identify last row and column with data
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    ' Path to export the data
    filePath = "C:\Path\To\Output\File.csv"
    
    ' Export selected range to a CSV file
    With ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol))
        .Copy
        With Application.Workbooks.Add
            .Sheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteValues
            .SaveAs Filename:=filePath, FileFormat:=xlCSV, CreateBackup:=False
            .Close SaveChanges:=False
        End With
    End With
    
    MsgBox "Data Export Completed to: " & filePath
End Sub

' Module: ArrayCollectionTools

Option Explicit

' Function: FindMaximum
' Finds the maximum value in a one-dimensional array of numbers.
Public Function FindMaximum(arr As Variant) As Double
    Dim i As Long
    Dim maxVal As Double
    maxVal = arr(LBound(arr))
    
    For i = LBound(arr) + 1 To UBound(arr)
        If arr(i) > maxVal Then
            maxVal = arr(i)
        End If
    Next i

    FindMaximum = maxVal
End Function

' Function: ReverseArray
' Reverses the order of elements in a one-dimensional array.
Public Function ReverseArray(arr As Variant) As Variant
    Dim i As Long
    Dim temp As Variant
    Dim reversed() As Variant
    Dim arrLen As Long
    arrLen = UBound(arr) - LBound(arr) + 1
    ReDim reversed(LBound(arr) To UBound(arr))

    For i = LBound(arr) To UBound(arr)
        reversed(UBound(arr) - i) = arr(i)
    Next i

    ReverseArray = reversed
End Function

' Function: ArrayToCollection
' Converts a one-dimensional array to a Collection.
Public Function ArrayToCollection(arr As Variant) As Collection
    Dim col As New Collection
    Dim i As Long

    For i = LBound(arr) To UBound(arr)
        col.Add arr(i)
    Next i

    Set ArrayToCollection = col
End Function

' Function: RemoveDuplicates
' Removes duplicate elements from a Collection and returns a new Collection.
Public Function RemoveDuplicates(col As Collection) As Collection
    Dim uniqueCol As New Collection
    Dim item As Variant
    Dim dict As Object
    
    Set dict = CreateObject("Scripting.Dictionary")

    For Each item In col
        If Not dict.Exists(item) Then
            dict.Add item, Nothing
            uniqueCol.Add item
        End If
    Next item

    Set RemoveDuplicates = uniqueCol
End Function

' Function: SortArray
' Sorts a one-dimensional array in ascending order using the Bubble Sort algorithm.
Public Function SortArray(arr As Variant) As Variant
    Dim i As Long, j As Long
    Dim temp As Variant
    Dim sortedArr() As Variant
    sortedArr = arr
    
    For i = LBound(sortedArr) To UBound(sortedArr) - 1
        For j = i + 1 To UBound(sortedArr)
            If sortedArr(i) > sortedArr(j) Then
                temp = sortedArr(i)
                sortedArr(i) = sortedArr(j)
                sortedArr(j) = temp
            End If
        Next j
    Next i

    SortArray = sortedArr
End Function

' Function: CollectionToString
' Concatenates all elements of a Collection into a single string separated by a delimiter.
Public Function CollectionToString(col As Collection, Optional delimiter As String = ",") As String
    Dim item As Variant
    Dim result As String

    For Each item In col
        result = result & item & delimiter
    Next item
    
    If Len(result) > 0 Then
        result = Left(result, Len(result) - Len(delimiter))
    End If

    CollectionToString = result
End Function

Sub ApplyConditionalFormatting()

    Dim ws As Worksheet
    Dim rng As Range
    Dim formatCondition As FormatCondition

    ' Set the worksheet you're working with
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' Define the range you want to apply conditional formatting
    Set rng = ws.Range("A1:A100")
    
    ' Clear any existing conditional formats in the range
    rng.FormatConditions.Delete
    
    ' Add a new conditional format for cells with values greater than 10
    Set formatCondition = rng.FormatConditions.Add(Type:=xlCellValue, _
                                                   Operator:=xlGreater, _
                                                   Formula1:="10")
    
    ' Set the format to be applied (e.g., yellow fill)
    With formatCondition.Interior
        .Color = RGB(255, 255, 0) ' Yellow
    End With
    
End Sub

' Data Validation Routines in Excel using VBA

Option Explicit

' Routine: ValidateData
' Validates a given range of data based on multiple rules.
Public Sub ValidateData(dataRange As Range)
    Dim cell As Range
    Dim errorLog As String
    errorLog = "Data Validation Errors:" & vbCrLf
    
    ' Iterate through each cell in the provided range
    For Each cell In dataRange
        Dim errorFound As Boolean
        errorFound = False
        
        ' Example Rule 1: Check for empty cells
        If IsEmpty(cell.Value) Then
            errorLog = errorLog & "Empty value at " & cell.Address & vbCrLf
            errorFound = True
        End If
        
        ' Example Rule 2: Numerical Data Validation (e.g., must be > 0)
        If IsNumeric(cell.Value) And cell.Value  Len("Data Validation Errors:" & vbCrLf) Then
        MsgBox errorLog, vbExclamation, "Validation Errors"
    Else
        MsgBox "All data is valid!", vbInformation, "Validation Successful"
    End If
End Sub

' Helper Function: ValidateText
' Checks for invalid characters in text (e.g., no special characters).
Private Function ValidateText(text As String) As Boolean
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "[^a-zA-Z0-9 ]" ' Allows only alphanumeric characters
    regex.IgnoreCase = True
    ValidateText = Not regex.test(text)
End Function

' Usage Example:
' ValidateData Range("A1:C10")

Sub SetDataVisualizationPresets()

    Dim chartObject As ChartObject
    Dim worksheet As Worksheet
    Dim chartTitle As String
    Dim xAxisTitle As String
    Dim yAxisTitle As String
    Dim chartType As XlChartType
    Dim isShowingLegend As Boolean

    ' Define visualization presets
    chartTitle = "Sales by Quarter"
    xAxisTitle = "Quarters"
    yAxisTitle = "Sales Revenue"
    chartType = xlColumnClustered
    isShowingLegend = True

    ' Loop over charts on the active sheet and apply presets
    Set worksheet = ActiveSheet
    For Each chartObject In worksheet.ChartObjects
        
        With chartObject.Chart
            ' Apply the chart type
            .ChartType = chartType
            
            ' Set chart title
            .HasTitle = True
            .ChartTitle.Text = chartTitle
            
            ' Set axis titles
            With .Axes(xlCategory)
                .HasTitle = True
                .AxisTitle.Text = xAxisTitle
            End With
            With .Axes(xlValue)
                .HasTitle = True
                .AxisTitle.Text = yAxisTitle
            End With

            ' Manage legend
            .HasLegend = isShowingLegend

            ' Format chart area
            .ChartArea.Format.Fill.ForeColor.RGB = RGB(242, 242, 242)
            .PlotArea.Format.Fill.ForeColor.RGB = RGB(255, 255, 255)
            
            ' Adjust font style
            With .ChartTitle.Format.TextFrame2.TextRange.Font
                .Size = 14
                .Bold = msoTrue
            End With
            With .Axes(xlCategory).Format.TextFrame2.TextRange.Font
                .Size = 10
                .Bold = msoFalse
            End With
            With .Axes(xlValue).Format.TextFrame2.TextRange.Font
                .Size = 10
                .Bold = msoFalse
            End With

        End With
    Next chartObject

End Sub

' Define the Worksheet object
Private WithEvents ws As Worksheet

' Initialize the worksheet event handler
Private Sub Workbook_Open()
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to your specific worksheet name
End Sub

' Worksheet Change Event: Captures changes made to the worksheet
Private Sub ws_Change(ByVal Target As Range)
    ' Check if the change occurs in column A
    If Not Intersect(Target, ws.Columns("A")) Is Nothing Then
        ' Example: Show a message box indicating a change was made in column A
        MsgBox "Change detected in Column A!", vbInformation
    End If
End Sub

' Worksheet BeforeDoubleClick Event: Captures double-clicks within the worksheet
Private Sub ws_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    ' Example: Cancel the default double-click action and display a message box
    Cancel = True
    MsgBox "Cell " & Target.Address & " was double-clicked!", vbExclamation
End Sub

' Worksheet SelectionChange Event: Captures selection changes within the worksheet
Private Sub ws_SelectionChange(ByVal Target As Range)
    ' Example: Clear the status bar whenever the selection changes
    Application.StatusBar = False
    Application.StatusBar = "You have selected " & Target.Address
End Sub

' Clean up the worksheet object when the workbook is closed
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set ws = Nothing
End Sub

' Integrating with External Data Sources in VBA
' This practical implementation will show how to connect to an external data source (e.g., an Access database) and extract data into Excel.

Sub ConnectToExternalDataSource()

    ' Declare Variables
    Dim con As Object
    Dim rs As Object
    Dim connectionString As String
    Dim query As String
    Dim targetSheet As Worksheet
    Dim i As Integer
    
    ' Set up the connection string (change file path and credentials as needed)
    connectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Path\To\Database.accdb;"
    
    ' SQL query to extract data
    query = "SELECT * FROM YourTableName;"
    
    ' Create new ADODB connection and recordset objects
    Set con = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    
    ' Open the connection
    con.Open connectionString
    
    ' Open the recordset with the query
    rs.Open query, con
    
    ' Set the target worksheet
    Set targetSheet = ThisWorkbook.Sheets("Sheet1")
    
    ' Clear previous data
    targetSheet.Cells.Clear
    
    ' Load field names into the first row
    For i = 0 To rs.Fields.Count - 1
        targetSheet.Cells(1, i + 1).Value = rs.Fields(i).Name
    Next i
    
    ' Load data from the recordset into the Excel worksheet
    targetSheet.Cells(2, 1).CopyFromRecordset rs
    
    ' Cleanup
    rs.Close
    con.Close
    Set rs = Nothing
    Set con = Nothing

    ' Inform the user that the data has been imported
    MsgBox "Data imported successfully!"
    
End Sub

' Optimize code by reducing repetitive computations and redundant operations

Sub OptimizePerformance()

    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim sumCache As Double
    Dim cellValue As Double
    
    ' Set reference to the target worksheet
    Set ws = ThisWorkbook.Sheets("DataSheet")
    
    ' Find the last row with data in column A
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    ' Preprocess operations that can be reduced to prior or minimal executions
    Application.ScreenUpdating = False    ' Disable screen updating
    Application.Calculation = xlCalculationManual  ' Disable automatic recalculation
    Application.EnableEvents = False      ' Disable events to prevent unnecessary triggers
    
    ' Use cache to keep sum total, avoiding repetitive calculations within the loop
    sumCache = 0
    
    For i = 1 To lastRow
        ' Retrieve cell value once, avoiding multiple accesses
        cellValue = ws.Cells(i, 1).Value
        ws.Cells(i, 2).Value = cellValue * 2  ' Sample operation: multiply value by 2
        sumCache = sumCache + cellValue ' Accumulate sum in cache
    Next i
    
    ' Place the cached sum in a cell outside the loop to prevent recalculating sum on each iteration
    ws.Cells(1, 3).Value = sumCache
    
    ' Re-enable Excel functionalities
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
End Sub

' *******************************************************
'   Module: BatchProcessor
'   Description: Executes batch processes and handles iterations
'                for Excel automation tasks.
' *******************************************************

' Batch Process Execution
Sub ExecuteBatchProcess()
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range

    ' Set worksheet and range to iterate through
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set rng = ws.Range("A1:A100")

    ' Iterate over each cell in the range
    For Each cell In rng
        ProcessCellData cell
    Next cell
End Sub

' Processing function for each cell
Private Sub ProcessCellData(ByRef cell As Range)
    ' Example operation: Multiply value in cell by 2
    If IsNumeric(cell.Value) Then
        cell.Value = cell.Value * 2
    End If
End Sub

' Iterative Calculation Example
Sub PerformIterationCalculation()
    Dim i As Integer
    Dim result As Double
    Const iterations As Integer = 10
    
    ' Initialize result
    result = 1.0

    ' Perform iterative calculations
    For i = 1 To iterations
        result = result + i * 2.5  ' Example calculation
    Next i

    ' Output the result to a specific cell
    ThisWorkbook.Sheets("Sheet1").Range("B1").Value = result
End Sub

'--- Documenting and Testing Code Blocks ---'
'1. Sample Code Block for Documentation and Testing'

' This function calculates the sum of two numbers
Function AddNumbers(num1 As Double, num2 As Double) As Double
    AddNumbers = num1 + num2
End Function

'--- Unit Test for AddNumbers Function ---'
Sub TestAddNumbers()
    Dim result As Double
    Dim expectedResult As Double

    ' Test Case: Positive Numbers
    result = AddNumbers(2, 3)
    expectedResult = 5 ' Expected: 5
    Debug.Assert result = expectedResult ' Asserts if the result matches expected result

    ' Test Case: Negative Numbers
    result = AddNumbers(-2, -3)
    expectedResult = -5 ' Expected: -5
    Debug.Assert result = expectedResult

    ' Test Case: Mixed Sign Numbers
    result = AddNumbers(-2, 3)
    expectedResult = 1 ' Expected: 1
    Debug.Assert result = expectedResult

    ' Add more test cases as needed...
End Sub

'--- Documentation Best Practices ---'
' 1. Use comments to describe the purpose and functionality of the code block.
' 2. Document parameters, return values, and any side effects.
' 3. Use inline comments to explain complex logic if necessary.
' 4. Clearly separate test cases with comments and ensure expected results are known.
' 5. Utilize the Debug.Assert function to facilitate testing during development.