Free VBA Templates Library

Sub AnalyzeDataTrends()
    Dim ws As Worksheet
    Dim dataRange As Range
    Dim lastRow As Long
    Dim average As Double
    Dim stdev As Double

    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Set dataRange = ws.Range("B2:B" & lastRow)

    ' Calculate statistics
    average = Application.WorksheetFunction.Average(dataRange)
    stdev = Application.WorksheetFunction.StDev(dataRange)

    ' Create summary
    ws.Range("E1").Value = "Analysis Summary"
    ws.Range("E2").Value = "Average: " & Round(average, 2)
    ws.Range("E3").Value = "Std Dev: " & Round(stdev, 2)
    ws.Range("E4").Value = "Count: " & dataRange.Count

    ' Highlight outliers
    Dim cell As Range
    For Each cell In dataRange
        If Abs(cell.Value - average) > 2 * stdev Then
            cell.Interior.Color = RGB(255, 200, 200)
        End If
    Next cell

    MsgBox "Data analysis complete!"
End Sub

Sub ROICalculator()
    Dim ws As Worksheet
    Dim initialInvestment As Double
    Dim annualCashFlow As Double
    Dim years As Integer
    Dim discountRate As Double
    Dim scenarios As Variant
    Dim i As Long

    ' Create new worksheet
    Set ws = Worksheets.Add
    ws.Name = "ROI_Analysis_" & Format(Date, "mmyyyy")

    ' Get input parameters
    initialInvestment = CDbl(InputBox("Enter initial investment amount:"))
    annualCashFlow = CDbl(InputBox("Enter expected annual cash flow:"))
    years = CInt(InputBox("Enter investment period (years):"))
    discountRate = CDbl(InputBox("Enter discount rate (e.g., 0.10 for 10%):"))

    ' Set up headers
    ws.Range("A1").Value = "ROI Analysis Report"
    ws.Range("A1").Font.Size = 16
    ws.Range("A1").Font.Bold = True

    ws.Range("A3").Value = "Investment Parameters:"
    ws.Range("A4").Value = "Initial Investment:"
    ws.Range("B4").Value = initialInvestment
    ws.Range("B4").NumberFormat = "£#,##0.00"

    ws.Range("A5").Value = "Annual Cash Flow:"
    ws.Range("B5").Value = annualCashFlow
    ws.Range("B5").NumberFormat = "£#,##0.00"

    ws.Range("A6").Value = "Investment Period:"
    ws.Range("B6").Value = years & " years"

    ws.Range("A7").Value = "Discount Rate:"
    ws.Range("B7").Value = discountRate
    ws.Range("B7").NumberFormat = "0.00%"

    ' Calculate metrics
    Dim totalCashFlow As Double
    Dim npv As Double
    Dim roi As Double
    Dim paybackPeriod As Double

    totalCashFlow = annualCashFlow * years
    roi = (totalCashFlow - initialInvestment) / initialInvestment
    paybackPeriod = initialInvestment / annualCashFlow

    ' Calculate NPV
    npv = -initialInvestment
    For i = 1 To years
        npv = npv + (annualCashFlow / ((1 + discountRate) ^ i))
    Next i

    ' Display results
    ws.Range("A9").Value = "Results:"
    ws.Range("A10").Value = "Simple ROI:"
    ws.Range("B10").Value = roi
    ws.Range("B10").NumberFormat = "0.00%"

    ws.Range("A11").Value = "Net Present Value:"
    ws.Range("B11").Value = npv
    ws.Range("B11").NumberFormat = "£#,##0.00"

    ws.Range("A12").Value = "Payback Period:"
    ws.Range("B12").Value = paybackPeriod & " years"

    ' Scenario analysis
    scenarios = Array(-0.2, -0.1, 0, 0.1, 0.2)  ' -20% to +20%

    ws.Range("A14").Value = "Scenario Analysis:"
    ws.Range("A15").Value = "Cash Flow Change"
    ws.Range("B15").Value = "New NPV"
    ws.Range("C15").Value = "New ROI"

    For i = 0 To UBound(scenarios)
        Dim scenarioCashFlow As Double
        Dim scenarioNPV As Double
        Dim scenarioROI As Double
        Dim j As Long

        scenarioCashFlow = annualCashFlow * (1 + scenarios(i))
        scenarioNPV = -initialInvestment

        For j = 1 To years
            scenarioNPV = scenarioNPV + (scenarioCashFlow / ((1 + discountRate) ^ j))
        Next j

        scenarioROI = ((scenarioCashFlow * years) - initialInvestment) / initialInvestment

        ws.Cells(16 + i, 1).Value = Format(scenarios(i), "0%")
        ws.Cells(16 + i, 2).Value = scenarioNPV
        ws.Cells(16 + i, 2).NumberFormat = "£#,##0.00"
        ws.Cells(16 + i, 3).Value = scenarioROI
        ws.Cells(16 + i, 3).NumberFormat = "0.00%"
    Next i

    ' Format and autofit
    ws.Columns.AutoFit
    ws.Range("A3:A12,A14:A15").Font.Bold = True

    MsgBox "ROI analysis completed with scenario analysis!"
End Sub

Sub CreateDynamicChart()
    Dim ws As Worksheet
    Dim chartWs As Worksheet
    Dim dataRange As Range
    Dim chartObj As ChartObject
    Dim lastRow As Long

    Set ws = ActiveSheet
    Set chartWs = Worksheets.Add
    chartWs.Name = "Charts_" & Format(Date, "mmyyyy")

    ' Define dynamic range
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    Set dataRange = ws.Range("A1:B" & lastRow)

    ' Create chart
    Set chartObj = chartWs.ChartObjects.Add(50, 50, 400, 300)

    With chartObj.Chart
        .SetSourceData dataRange
        .ChartType = xlLine
        .HasTitle = True
        .ChartTitle.Text = "Dynamic Data Chart"
        .HasLegend = True
    End With

    ' Create named range for dynamic updates
    ActiveWorkbook.Names.Add Name:="DynamicData", _
        RefersTo:="=" & ws.Name & "!$A$1:$B$" & lastRow

    MsgBox "Dynamic chart created!"
End Sub

Sub HighlightDuplicates()
    Dim dataRange As Range
    Dim cell As Range
    Dim duplicateFormat As FormatCondition

    ' Select the data range
    Set dataRange = Application.InputBox("Select range to check for duplicates:", Type:=8)

    If dataRange Is Nothing Then Exit Sub

    ' Clear existing conditional formatting
    dataRange.FormatConditions.Delete

    ' Add conditional formatting for duplicates
    Set duplicateFormat = dataRange.FormatConditions.AddUniqueValues
    duplicateFormat.DupeUnique = xlDuplicate
    duplicateFormat.Interior.Color = RGB(255, 199, 206)  ' Light red background
    duplicateFormat.Font.Color = RGB(156, 0, 6)         ' Dark red text

    MsgBox "Duplicate values highlighted successfully!"
End Sub

Sub CleanDataRange()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long

    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' Remove duplicates
    ws.Range("A1:C" & lastRow).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes

    ' Clean up text formatting
    For i = 2 To lastRow
        ws.Cells(i, 1).Value = Trim(UCase(ws.Cells(i, 1).Value))
        ws.Cells(i, 2).Value = Trim(ws.Cells(i, 2).Value)
    Next i

    MsgBox "Data cleanup complete!"
End Sub

Sub SendAutomatedEmails()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long

    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Set OutApp = CreateObject("Outlook.Application")

    For i = 2 To lastRow
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = ws.Cells(i, 2).Value
            .Subject = "Monthly Update - " & ws.Cells(i, 1).Value
            .Body = "Dear " & ws.Cells(i, 1).Value & "," & vbCrLf & _
                    "Your monthly summary is ready." & vbCrLf & _
                    "Total: " & ws.Cells(i, 3).Value
            .Send
        End With
        Set OutMail = Nothing
    Next i

    Set OutApp = Nothing
    MsgBox "Emails sent successfully!"
End Sub

Sub BatchProcessFiles()
    Dim folderPath As String
    Dim fileName As String
    Dim wb As Workbook
    Dim ws As Worksheet

    folderPath = "C:\Data\" ' Change this path
    fileName = Dir(folderPath & "*.xlsx")

    Do While fileName <> ""
        Set wb = Workbooks.Open(folderPath & fileName)
        Set ws = wb.Sheets(1)

        ' Process each file (example: add timestamp)
        ws.Range("A1").Value = "Processed: " & Now()

        wb.Save
        wb.Close False

        fileName = Dir()
    Loop

    MsgBox "Batch processing complete!"
End Sub

Sub GenerateMonthlyReport()
    Dim ws As Worksheet
    Dim reportWs As Worksheet
    Dim lastRow As Long

    Set ws = Sheets("Data")
    Set reportWs = Sheets.Add(After:=Sheets(Sheets.Count))
    reportWs.Name = "Report_" & Format(Date, "mmyyyy")

    ' Copy and format headers
    ws.Range("A1:D1").Copy reportWs.Range("A1")
    With reportWs.Range("A1:D1")
        .Font.Bold = True
        .Interior.Color = RGB(79, 129, 189)
        .Font.Color = RGB(255, 255, 255)
    End With

    ' Add summary calculations
    reportWs.Range("F1").Value = "Total Records:"
    reportWs.Range("G1").Formula = "=COUNTA(A:A)-1"

    MsgBox "Monthly report generated successfully!"
End Sub

Sub CreateDashboard()
    Dim dashWs As Worksheet
    Dim chartObj As ChartObject
    Dim dataRange As Range

    ' Create dashboard worksheet
    Set dashWs = Worksheets.Add
    dashWs.Name = "Dashboard_" & Format(Date, "mmyyyy")

    ' Add title
    With dashWs.Range("A1:F1")
        .Merge
        .Value = "Executive Dashboard - " & Format(Date, "mmmm yyyy")
        .Font.Size = 16
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With

    ' Create sample chart
    Set dataRange = Sheets("Data").Range("A1:B10")
    Set chartObj = dashWs.ChartObjects.Add(50, 50, 300, 200)

    With chartObj.Chart
        .SetSourceData dataRange
        .ChartType = xlColumnClustered
        .HasTitle = True
        .ChartTitle.Text = "Monthly Performance"
    End With

    MsgBox "Dashboard created successfully!"
End Sub

Sub ManageWorksheets()
    Dim operation As String
    Dim sheetName As String
    Dim newName As String
    Dim ws As Worksheet

    operation = InputBox("Choose operation: ADD, RENAME, DELETE, or ORGANIZE:", "Sheet Manager")

    Select Case UCase(operation)
        Case "ADD"
            sheetName = InputBox("Enter name for new sheet:")
            If sheetName <> "" Then
                Set ws = Worksheets.Add
                ws.Name = sheetName
                MsgBox "Sheet  & sheetName &  added successfully!"
            End If

        Case "RENAME"
            sheetName = InputBox("Enter current sheet name:")
            newName = InputBox("Enter new sheet name:")
            If sheetName <> "" And newName <> "" Then
                Worksheets(sheetName).Name = newName
                MsgBox "Sheet renamed successfully!"
            End If

        Case "DELETE"
            sheetName = InputBox("Enter sheet name to delete:")
            If sheetName <> "" Then
                If MsgBox("Delete sheet  & sheetName & ?", vbYesNo) = vbYes Then
                    Application.DisplayAlerts = False
                    Worksheets(sheetName).Delete
                    Application.DisplayAlerts = True
                    MsgBox "Sheet deleted successfully!"
                End If
            End If

        Case "ORGANIZE"
            ' Sort sheets alphabetically
            Dim i As Integer, j As Integer
            For i = 1 To Sheets.Count - 1
                For j = i + 1 To Sheets.Count
                    If Sheets(i).Name > Sheets(j).Name Then
                        Sheets(j).Move Before:=Sheets(i)
                    End If
                Next j
            Next i
            MsgBox "Sheets organised alphabetically!"
    End Select
End Sub

Sub CalculateCorrelations()
    Dim ws As Worksheet
    Dim xRange As Range, yRange As Range
    Dim correlation As Double
    Dim lastRow As Long

    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    ' Define data ranges
    Set xRange = ws.Range("A2:A" & lastRow)
    Set yRange = ws.Range("B2:B" & lastRow)

    ' Calculate correlation
    correlation = Application.WorksheetFunction.Correl(xRange, yRange)

    ' Output results
    ws.Range("D1").Value = "Correlation Analysis"
    ws.Range("D2").Value = "Correlation: " & Round(correlation, 4)

    ' Interpret correlation strength
    Select Case Abs(correlation)
        Case Is >= 0.7
            ws.Range("D3").Value = "Strong correlation"
        Case Is >= 0.3
            ws.Range("D3").Value = "Moderate correlation"
        Case Else
            ws.Range("D3").Value = "Weak correlation"
    End Select

    MsgBox "Correlation analysis complete! R = " & Round(correlation, 4)
End Sub

Sub DataQualityCheck()
    Dim ws As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim i As Long, j As Long
    Dim blankCount As Long, errorCount As Long
    Dim totalCells As Long

    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    totalCells = lastRow * lastCol

    ' Check for blanks and errors
    For i = 1 To lastRow
        For j = 1 To lastCol
            If IsEmpty(ws.Cells(i, j)) Then
                blankCount = blankCount + 1
            ElseIf IsError(ws.Cells(i, j)) Then
                errorCount = errorCount + 1
                ws.Cells(i, j).Interior.Color = RGB(255, 0, 0) ' Highlight errors in red
            End If
        Next j
    Next i

    ' Create quality report
    ws.Range("A" & lastRow + 3).Value = "Data Quality Report"
    ws.Range("A" & lastRow + 4).Value = "Total Cells: " & totalCells
    ws.Range("A" & lastRow + 5).Value = "Blank Cells: " & blankCount & " (" & Round((blankCount / totalCells) * 100, 2) & "%)"
    ws.Range("A" & lastRow + 6).Value = "Error Cells: " & errorCount & " (" & Round((errorCount / totalCells) * 100, 2) & "%)"
    ws.Range("A" & lastRow + 7).Value = "Data Completeness: " & Round(((totalCells - blankCount) / totalCells) * 100, 2) & "%"

    MsgBox "Data quality check complete! Found " & blankCount & " blanks and " & errorCount & " errors."
End Sub

Sub ScenarioAnalysisTool()
    Dim ws As Worksheet
    Dim scenarioWs As Worksheet
    Dim baseValue As Double
    Dim scenarios As Variant
    Dim i As Long

    Set ws = ActiveSheet
    Set scenarioWs = Worksheets.Add
    scenarioWs.Name = "Scenario_Analysis"

    ' Get base case value
    baseValue = ws.Range("B1").Value ' Adjust cell reference as needed

    ' Define scenarios (percentage changes)
    scenarios = Array(-0.2, -0.1, 0, 0.1, 0.2, 0.3) ' -20% to +30%

    ' Create scenario table
    scenarioWs.Range("A1").Value = "Scenario Analysis"
    scenarioWs.Range("A2").Value = "Change %"
    scenarioWs.Range("B2").Value = "New Value"
    scenarioWs.Range("C2").Value = "Impact"

    For i = 0 To UBound(scenarios)
        scenarioWs.Cells(i + 3, 1).Value = Format(scenarios(i), "0%")
        scenarioWs.Cells(i + 3, 2).Value = baseValue * (1 + scenarios(i))
        scenarioWs.Cells(i + 3, 3).Value = (baseValue * (1 + scenarios(i))) - baseValue
    Next i

    ' Format the table
    With scenarioWs.Range("A2:C" & UBound(scenarios) + 3)
        .Borders.LineStyle = xlContinuous
        .Font.Size = 10
    End With

    scenarioWs.Range("A2:C2").Font.Bold = True

    MsgBox "Scenario analysis table created!"
End Sub

Sub CreateMultiChartDashboard()
    Dim ws As Worksheet
    Dim dashWs As Worksheet
    Dim chart1 As ChartObject, chart2 As ChartObject, chart3 As ChartObject

    Set ws = Sheets("Data") ' Assumes data is in a sheet named "Data"
    Set dashWs = Worksheets.Add
    dashWs.Name = "Dashboard_" & Format(Date, "mmyyyy")

    ' Chart 1: Column Chart
    Set chart1 = dashWs.ChartObjects.Add(50, 50, 300, 200)
    With chart1.Chart
        .SetSourceData ws.Range("A1:B10")
        .ChartType = xlColumnClustered
        .HasTitle = True
        .ChartTitle.Text = "Sales by Month"
    End With

    ' Chart 2: Pie Chart
    Set chart2 = dashWs.ChartObjects.Add(400, 50, 300, 200)
    With chart2.Chart
        .SetSourceData ws.Range("D1:E5")
        .ChartType = xlPie
        .HasTitle = True
        .ChartTitle.Text = "Product Mix"
    End With

    ' Chart 3: Line Chart
    Set chart3 = dashWs.ChartObjects.Add(225, 300, 300, 200)
    With chart3.Chart
        .SetSourceData ws.Range("A1:C10")
        .ChartType = xlLine
        .HasTitle = True
        .ChartTitle.Text = "Trend Analysis"
    End With

    MsgBox "Multi-chart dashboard created!"
End Sub

Sub ApplyColourScale()
    Dim dataRange As Range
    Dim colourScale As ColorScale

    ' Select the data range
    Set dataRange = Application.InputBox("Select range for colour scaling:", Type:=8)

    If dataRange Is Nothing Then Exit Sub

    ' Clear existing conditional formatting
    dataRange.FormatConditions.Delete

    ' Add 3-colour scale
    Set colourScale = dataRange.FormatConditions.AddColorScale(ColorScaleType:=3)

    ' Configure colours: Red (low) -> Yellow (middle) -> Green (high)
    With colourScale.ColorScaleCriteria(1)
        .Type = xlConditionValueLowestValue
        .FormatColor.Color = RGB(248, 105, 107)  ' Red
    End With

    With colourScale.ColorScaleCriteria(2)
        .Type = xlConditionValuePercentile
        .Value = 50
        .FormatColor.Color = RGB(255, 235, 132)  ' Yellow
    End With

    With colourScale.ColorScaleCriteria(3)
        .Type = xlConditionValueHighestValue
        .FormatColor.Color = RGB(99, 190, 123)   ' Green
    End With

    MsgBox "Colour scale applied successfully!"
End Sub

Sub CustomFormulaFormatting()
    Dim dataRange As Range
    Dim formulaCondition As FormatCondition
    Dim formula As String

    ' Select the data range
    Set dataRange = Application.InputBox("Select range for custom formatting:", Type:=8)

    If dataRange Is Nothing Then Exit Sub

    ' Get custom formula from user
    formula = InputBox("Enter formula (use relative references, e.g., =AND(A1>100, B1<50)):", "Custom Formula")

    If formula = "" Then Exit Sub

    ' Clear existing conditional formatting
    dataRange.FormatConditions.Delete

    ' Add custom formula condition
    Set formulaCondition = dataRange.FormatConditions.Add( _
        Type:=xlExpression, _
        Formula1:=formula)

    ' Format cells that meet the condition
    With formulaCondition
        .Interior.Color = RGB(198, 224, 180)  ' Light green background
        .Font.Color = RGB(56, 87, 35)         ' Dark green text
        .Font.Bold = True
    End With

    MsgBox "Custom conditional formatting applied!"
End Sub

Sub AddDataBars()
    Dim dataRange As Range
    Dim dataBar As Databar

    ' Select the data range
    Set dataRange = Application.InputBox("Select range for data bars:", Type:=8)

    If dataRange Is Nothing Then Exit Sub

    ' Clear existing conditional formatting
    dataRange.FormatConditions.Delete

    ' Add data bars
    Set dataBar = dataRange.FormatConditions.AddDatabar

    ' Configure data bar appearance
    With dataBar
        .MinPoint.Modify newtype:=xlConditionValueAutomaticMin
        .MaxPoint.Modify newtype:=xlConditionValueAutomaticMax
        .BarColor.Color = RGB(91, 155, 213)  ' Blue bars
        .ShowValue = True  ' Show values alongside bars
        .BarFillType = xlDataBarFillSolid
    End With

    MsgBox "Data bars added successfully!"
End Sub

Sub AddIconSets()
    Dim dataRange As Range
    Dim iconSet As IconSetCondition

    ' Select the data range
    Set dataRange = Application.InputBox("Select range for icon indicators:", Type:=8)

    If dataRange Is Nothing Then Exit Sub

    ' Clear existing conditional formatting
    dataRange.FormatConditions.Delete

    ' Add traffic light icon set
    Set iconSet = dataRange.FormatConditions.AddIconSetCondition

    With iconSet
        .IconSet = ActiveWorkbook.IconSets(xl3TrafficLights1)
        .ShowIconOnly = False  ' Show both icons and values

        ' Configure thresholds
        .IconCriteria(2).Type = xlConditionValuePercent
        .IconCriteria(2).Value = 33
        .IconCriteria(2).Operator = xlGreaterEqual

        .IconCriteria(3).Type = xlConditionValuePercent
        .IconCriteria(3).Value = 67
        .IconCriteria(3).Operator = xlGreaterEqual
    End With

    MsgBox "Icon indicators added successfully!"
End Sub

Sub ImportCSVWithTypes()
    Dim filePath As String
    Dim ws As Worksheet
    Dim qt As QueryTable
    Dim lastRow As Long, lastCol As Long

    ' Get CSV file path
    filePath = Application.GetOpenFilename("CSV Files (*.csv), *.csv")
    If filePath = "False" Then Exit Sub

    ' Create new worksheet for import
    Set ws = Worksheets.Add
    ws.Name = "Imported_" & Format(Now, "mmdd_hhmm")

    ' Import CSV with QueryTable for better control
    Set qt = ws.QueryTables.Add( _
        Connection:="TEXT;" & filePath, _
        Destination:=ws.Range("A1"))

    With qt
        .TextFileParseType = xlDelimited
        .TextFileCommaDelimiter = True
        .TextFileConsecutiveDelimiter = False
        .RefreshStyle = xlInsertDeleteCells
        .Refresh BackgroundQuery:=False
    End With

    ' Auto-detect and apply data types
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

    Dim col As Long
    For col = 1 To lastCol
        ' Check if column contains dates
        If IsDate(ws.Cells(2, col).Value) Then
            ws.Columns(col).NumberFormat = "dd/mm/yyyy"
        ' Check if column contains numbers
        ElseIf IsNumeric(ws.Cells(2, col).Value) And ws.Cells(2, col).Value <> "" Then
            ws.Columns(col).NumberFormat = "0.00"
        End If
    Next col

    ' Auto-fit columns
    ws.Columns.AutoFit

    qt.Delete
    MsgBox "CSV imported successfully with " & lastRow & " rows and " & lastCol & " columns!"
End Sub

Sub ConnectToDatabase()
    Dim conn As Object
    Dim rs As Object
    Dim ws As Worksheet
    Dim sql As String
    Dim connectionString As String
    Dim col As Long

    ' Database connection string (modify as needed)
    connectionString = InputBox("Enter connection string:" & vbCrLf & _
        "Example: Provider=SQLOLEDB;Data Source=server;Initial Catalog=database;Integrated Security=SSPI;")

    If connectionString = "" Then Exit Sub

    ' SQL query
    sql = InputBox("Enter SQL query:", "SQL Query", "SELECT * FROM TableName")
    If sql = "" Then Exit Sub

    ' Create connection
    Set conn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")

    On Error GoTo ErrorHandler

    ' Open connection
    conn.Open connectionString

    ' Execute query
    rs.Open sql, conn

    ' Create new worksheet
    Set ws = Worksheets.Add
    ws.Name = "DBData_" & Format(Now, "mmdd_hhmm")

    ' Add column headers
    For col = 0 To rs.Fields.Count - 1
        ws.Cells(1, col + 1).Value = rs.Fields(col).Name
    Next col

    ' Copy data
    ws.Range("A2").CopyFromRecordset rs

    ' Format the data
    With ws.Range("A1").CurrentRegion
        .Font.Name = "Arial"
        .Font.Size = 10
        .Borders.LineStyle = xlContinuous
    End With

    ws.Rows(1).Font.Bold = True
    ws.Columns.AutoFit

    ' Clean up
    rs.Close
    conn.Close
    Set rs = Nothing
    Set conn = Nothing

    MsgBox "Database query executed successfully!"
    Exit Sub

ErrorHandler:
    MsgBox "Database error: " & Err.Description
    If Not rs Is Nothing Then rs.Close
    If Not conn Is Nothing Then conn.Close
End Sub

Sub AdvancedFindReplace()
    Dim ws As Worksheet
    Dim findText As String, replaceText As String
    Dim replaceCount As Long

    Set ws = ActiveSheet

    findText = InputBox("Enter text to find:")
    If findText = "" Then Exit Sub

    replaceText = InputBox("Enter replacement text:")

    ' Perform find and replace with options
    With ws.UsedRange
        replaceCount = 0
        For Each cell In .Cells
            If InStr(cell.Value, findText) > 0 Then
                cell.Value = Replace(cell.Value, findText, replaceText)
                replaceCount = replaceCount + 1
            End If
        Next cell
    End With

    MsgBox "Replaced " & replaceCount & " occurrences of \"" & findText & "\""
End Sub

Sub RemoveEmptyRowsAndColumns()
    Dim ws As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim i As Long, j As Long

    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

    ' Remove empty rows (from bottom to top)
    For i = lastRow To 2 Step -1
        If Application.WorksheetFunction.CountA(ws.Rows(i)) = 0 Then
            ws.Rows(i).Delete
        End If
    Next i

    ' Remove empty columns (from right to left)
    For j = lastCol To 1 Step -1
        If Application.WorksheetFunction.CountA(ws.Columns(j)) = 0 Then
            ws.Columns(j).Delete
        End If
    Next j

    MsgBox "Empty rows and columns removed!"
End Sub

Sub TextToColumnsAutomation()
    Dim ws As Worksheet
    Dim dataRange As Range
    Dim delimiter As String

    Set ws = ActiveSheet
    delimiter = InputBox("Enter delimiter (comma, semicolon, space, etc.):", "Delimiter", ",")

    If delimiter = "" Then Exit Sub

    ' Select the range containing text to split
    Set dataRange = Application.InputBox("Select range to split:", Type:=8)

    ' Split the text using the specified delimiter
    dataRange.TextToColumns Destination:=dataRange, _
        DataType:=xlDelimited, _
        Other:=True, _
        OtherChar:=delimiter, _
        ConsecutiveDelimiter:=False

    MsgBox "Text split into columns successfully!"
End Sub

Sub ScrapeWebData()
    Dim http As Object
    Dim html As Object
    Dim url As String
    Dim response As String
    Dim tables As Object
    Dim table As Object
    Dim rows As Object
    Dim cells As Object
    Dim ws As Worksheet
    Dim r As Long, c As Long

    ' Get URL from user
    url = InputBox("Enter website URL to scrape:")
    If url = "" Then Exit Sub

    ' Create HTTP request object
    Set http = CreateObject("MSXML2.XMLHTTP")

    ' Make request
    http.Open "GET", url, False
    http.send

    ' Get response
    response = http.responseText

    ' Parse HTML
    Set html = CreateObject("HTMLFile")
    html.body.innerHTML = response

    ' Create new worksheet
    Set ws = Worksheets.Add
    ws.Name = "WebData_" & Format(Now, "mmdd_hhmm")

    ' Find and extract table data
    Set tables = html.getElementsByTagName("table")

    If tables.Length > 0 Then
        Set table = tables(0)  ' Get first table
        Set rows = table.getElementsByTagName("tr")

        r = 1
        For Each row In rows
            Set cells = row.getElementsByTagName("td")
            If cells.Length = 0 Then
                Set cells = row.getElementsByTagName("th")  ' Header cells
            End If

            c = 1
            For Each cell In cells
                ws.Cells(r, c).Value = cell.innerText
                c = c + 1
            Next cell
            r = r + 1
        Next row

        ' Format the data
        With ws.Range("A1").CurrentRegion
            .Font.Name = "Arial"
            .Font.Size = 10
            .Borders.LineStyle = xlContinuous
        End With

        ' Make header bold
        ws.Rows(1).Font.Bold = True
        ws.Columns.AutoFit

        MsgBox "Web data extracted successfully!"
    Else
        MsgBox "No tables found on the webpage."
    End If
End Sub

Sub EmailTemplateManager()
    Dim templateName As String
    Dim emailBody As String
    Dim OutApp As Object
    Dim OutMail As Object

    ' Define email templates
    templateName = InputBox("Enter template name (welcome, followup, reminder):")

    Select Case LCase(templateName)
        Case "welcome"
            emailBody = "Welcome to our service! We are excited to have you on board."
        Case "followup"
            emailBody = "Following up on our previous communication. Please let us know if you have any questions."
        Case "reminder"
            emailBody = "This is a friendly reminder about your upcoming appointment."
        Case Else
            emailBody = InputBox("Enter custom email body:")
    End Select

    ' Create and send email
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        .Subject = "Subject: " & templateName
        .Body = emailBody
        .Display ' Show email for review before sending
    End With
End Sub

Sub SendEmailWithAttachments()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim ws As Worksheet
    Dim i As Long, lastRow As Long
    Dim filePath As String

    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Set OutApp = CreateObject("Outlook.Application")

    For i = 2 To lastRow
        filePath = ws.Cells(i, 4).Value ' Assuming file path is in column D

        If Dir(filePath) <> "" Then ' Check if file exists
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .To = ws.Cells(i, 2).Value
                .Subject = ws.Cells(i, 3).Value
                .Body = "Please find attached file."
                .Attachments.Add filePath
                .Send
            End With
            Set OutMail = Nothing
        End If
    Next i

    MsgBox "Emails with attachments sent!"
End Sub

Sub BatchConvertToPDF()
    Dim folderPath As String
    Dim outputPath As String
    Dim fileName As String
    Dim wb As Workbook
    Dim pdfName As String
    Dim fileCount As Long

    ' Get input folder
    folderPath = InputBox("Enter folder path containing Excel files:")
    If folderPath = "" Then Exit Sub

    ' Ensure path ends with backslash
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"

    ' Get output folder
    outputPath = InputBox("Enter output folder for PDF files:", "Output Folder", folderPath & "PDFs\")
    If outputPath = "" Then Exit Sub

    If Right(outputPath, 1) <> "\" Then outputPath = outputPath & "\"

    ' Create output folder if it doesn't exist
    If Dir(outputPath, vbDirectory) = "" Then
        MkDir outputPath
    End If

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    fileCount = 0
    fileName = Dir(folderPath & "*.xlsx")

    Do While fileName <> ""
        If fileName <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(folderPath & fileName)

            ' Create PDF filename
            pdfName = outputPath & Left(fileName, InStrRev(fileName, ".") - 1) & ".pdf"

            ' Export to PDF with custom settings
            wb.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                fileName:=pdfName, _
                Quality:=xlQualityStandard, _
                IncludeDocProps:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=False

            wb.Close SaveChanges:=False
            fileCount = fileCount + 1
        End If

        fileName = Dir()
    Loop

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    MsgBox "Converted " & fileCount & " Excel files to PDF!" & vbCrLf & _
           "PDFs saved to: " & outputPath
End Sub

Sub OrganizeFilesByDate()
    Dim sourceFolder As String
    Dim fileName As String
    Dim fileDate As Date
    Dim yearFolder As String
    Dim monthFolder As String
    Dim fso As Object

    Set fso = CreateObject("Scripting.FileSystemObject")
    sourceFolder = InputBox("Enter source folder path:")

    If sourceFolder = "" Then Exit Sub

    fileName = Dir(sourceFolder & "\*.*")

    Do While fileName <> ""
        fileDate = FileDateTime(sourceFolder & "\" & fileName)
        yearFolder = sourceFolder & "\" & Year(fileDate)
        monthFolder = yearFolder & "\" & Format(fileDate, "MM-mmmm")

        ' Create folders if they don't exist
        If Not fso.FolderExists(yearFolder) Then fso.CreateFolder yearFolder
        If Not fso.FolderExists(monthFolder) Then fso.CreateFolder monthFolder

        ' Move file to appropriate folder
        fso.MoveFile sourceFolder & "\" & fileName, monthFolder & "\" & fileName

        fileName = Dir()
    Loop

    MsgBox "Files organised by date!"
End Sub

Sub ConsolidateWorkbooks()
    Dim folderPath As String
    Dim fileName As String
    Dim wb As Workbook
    Dim masterWb As Workbook
    Dim masterWs As Worksheet
    Dim sourceWs As Worksheet
    Dim lastRow As Long

    folderPath = InputBox("Enter folder path containing workbooks to consolidate:")
    If folderPath = "" Then Exit Sub

    ' Create master workbook
    Set masterWb = Workbooks.Add
    Set masterWs = masterWb.Sheets(1)
    masterWs.Name = "Consolidated_Data"

    ' Add headers
    masterWs.Range("A1:D1").Value = Array("Source File", "Data1", "Data2", "Data3")

    fileName = Dir(folderPath & "\*.xlsx")
    lastRow = 2

    Do While fileName <> ""
        Set wb = Workbooks.Open(folderPath & "\" & fileName)
        Set sourceWs = wb.Sheets(1)

        ' Copy data (adjust range as needed)
        sourceWs.Range("A2:C100").Copy
        masterWs.Cells(lastRow, 2).PasteSpecial xlPasteValues

        ' Add source file name
        masterWs.Cells(lastRow, 1).Resize(sourceWs.Range("A2:C100").Rows.Count).Value = fileName

        lastRow = lastRow + sourceWs.Range("A2:C100").Rows.Count
        wb.Close False
        fileName = Dir()
    Loop

    MsgBox "Workbooks consolidated successfully!"
End Sub

Sub CreateAutomatedPivotTable()
    Dim ws As Worksheet
    Dim pivotWs As Worksheet
    Dim sourceRange As Range
    Dim pivotTable As pivotTable

    Set ws = ActiveSheet
    Set pivotWs = Worksheets.Add(After:=ws)
    pivotWs.Name = "Pivot_" & Format(Now, "mmddyyyy_hhmmss")

    ' Define source range (assuming data starts at A1)
    Set sourceRange = ws.Range("A1").CurrentRegion

    ' Create pivot table
    Set pivotTable = pivotWs.PivotTables.Add( _
        PivotCache:=ActiveWorkbook.PivotCaches.Create( _
            SourceType:=xlDatabase, _
            SourceData:=sourceRange), _
        TableDestination:=pivotWs.Range("A1"))

    MsgBox "Pivot table created! Configure fields as needed."
End Sub

Sub CreateBackup()
    Dim backupPath As String
    Dim fileName As String
    Dim timestamp As String
    Dim fullBackupPath As String

    ' Create timestamp
    timestamp = Format(Now, "yyyy-mm-dd_hh-mm-ss")

    ' Get current workbook info
    fileName = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1)

    ' Set backup path (same directory as original)
    backupPath = ThisWorkbook.Path & "\Backups\"

    ' Create backup directory if it doesn't exist
    If Dir(backupPath, vbDirectory) = "" Then
        MkDir backupPath
    End If

    ' Create full backup path
    fullBackupPath = backupPath & fileName & "_backup_" & timestamp & ".xlsx"

    ' Save backup copy
    Application.DisplayAlerts = False
    ThisWorkbook.SaveCopyAs fullBackupPath
    Application.DisplayAlerts = True

    MsgBox "Backup created: " & vbCrLf & fullBackupPath
End Sub

Sub SetupAutoBackup()
    ' Set up automatic backup on save
    ThisWorkbook.BeforeSave = True
    MsgBox "Auto-backup enabled! A backup will be created each time you save."
End Sub

Sub MergeWorkbooks()
    Dim folderPath As String
    Dim fileName As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim targetWb As Workbook
    Dim fileCount As Integer

    ' Get folder containing workbooks to merge
    folderPath = InputBox("Enter folder path containing workbooks to merge:")
    If folderPath = "" Then Exit Sub

    ' Ensure path ends with backslash
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"

    ' Create new workbook for merged data
    Set targetWb = Workbooks.Add
    targetWb.Sheets(1).Name = "Index"

    ' Add index header
    With targetWb.Sheets("Index")
        .Range("A1").Value = "Merged Workbooks Index"
        .Range("A2").Value = "Sheet Name"
        .Range("B2").Value = "Source File"
        .Range("C2").Value = "Merge Date"
        .Range("A1:C2").Font.Bold = True
    End With

    fileCount = 0
    fileName = Dir(folderPath & "*.xlsx")

    Application.ScreenUpdating = False

    Do While fileName <> ""
        If fileName <> targetWb.Name Then
            Set wb = Workbooks.Open(folderPath & fileName)

            ' Copy each sheet from source workbook
            For Each ws In wb.Worksheets
                ws.Copy After:=targetWb.Sheets(targetWb.Sheets.Count)
                ' Rename sheet to include source filename
                targetWb.Sheets(targetWb.Sheets.Count).Name = Left(fileName, InStrRev(fileName, ".") - 1) & "_" & ws.Name

                ' Add to index
                With targetWb.Sheets("Index")
                    .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Value = targetWb.Sheets(targetWb.Sheets.Count).Name
                    .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 1).Value = fileName
                    .Cells(.Rows.Count, 1).End(xlUp).Offset(0, 2).Value = Now
                End With
            Next ws

            wb.Close SaveChanges:=False
            fileCount = fileCount + 1
        End If

        fileName = Dir()
    Loop

    Application.ScreenUpdating = True

    MsgBox "Merged " & fileCount & " workbooks successfully!"
End Sub

Sub ProtectWorkbook()
    Dim password As String
    Dim protectionType As String

    password = InputBox("Enter password for protection:")
    If password = "" Then Exit Sub

    protectionType = InputBox("Protection type: WORKBOOK, SHEET, or BOTH:", "Protection Type")

    Select Case UCase(protectionType)
        Case "WORKBOOK"
            ThisWorkbook.Protect Password:=password, Structure:=True, Windows:=True
            MsgBox "Workbook structure protected!"

        Case "SHEET"
            ActiveSheet.Protect Password:=password, _
                DrawingObjects:=True, _
                Contents:=True, _
                Scenarios:=True, _
                AllowSorting:=True, _
                AllowFiltering:=True, _
                AllowFormattingCells:=False
            MsgBox "Current sheet protected with formatting restrictions!"

        Case "BOTH"
            ' Protect workbook structure
            ThisWorkbook.Protect Password:=password, Structure:=True, Windows:=True

            ' Protect all sheets
            Dim ws As Worksheet
            For Each ws In ThisWorkbook.Worksheets
                ws.Protect Password:=password, _
                    DrawingObjects:=True, _
                    Contents:=True, _
                    Scenarios:=True, _
                    AllowSorting:=True, _
                    AllowFiltering:=True
            Next ws

            MsgBox "Workbook and all sheets protected!"
    End Select
End Sub