Excel

Acronym Generator

Ease of Use

Easy

Version tested with

2000 

Submitted by:

MWE

Description:

Generates Acronyms from a table of possible possible words 

Discussion:

The AcronymRand procedure was written to generate virtually endless acronym definitions for the three letter acronym (TLA) "CMA". The "need" for such an unusal tool was the Off Topic forum thread (http://vbaexpress.com/forum/showthread.php?t=4680&page=1) about the initials CMA after kpuls' name and what they really mean. As silly as this might sound (and it was silly), the procedure has non-trivial value as it demonstrates how to randomly select values from an array or table (in this case columns of a spreadsheet). Each time the user clicks on the button "Get Single CMA Definition", the procedure selects a word randomly from each of three columns and displays the "definition". In the current "library" of words, there are approx 73 words for each letter. Thus the number of definitions approaches 400,000. So, a user might want to see more than one at a time. If the user clicks on "Get Multiple CMA Definitions", the demo procedure randomly decides how many definitions will be generated in the range [5,25] (demonstrating another random selection example), and then generates that number of definitions. NOTE that 25 definitions is about all the standard version of MsgBox can handle. The sheet containing the "library of words", is hidden but easily unhidden and expanded. The procedures are written to handle a more general case than 3-letter acronyms" 

Code:

instructions for use 

			
Option Explicit 
 
Sub AcronymRand(N, AcroLen, AcroLib, AcroName) 
     '
     '****************************************************************************************
     '
     '       Title       AcronymRand
     '       Target Application:  any
     '       Function    generates N random acronym definitions
     '       Passed Values:  (
     '           N         [in, numeric]   # of definitions to be generated
     '           AcroLen   [in, numeric]   length of acronym
     '           AcroLib   [in, string]    sheet name containing word library
     '           AcroName  [in, string]    displayed name for what is being generated
     '
     '****************************************************************************************
     '
     '
    Static Count    As Long 
    Dim I           As Integer 
    Dim J           As Long 
    Dim LR          As Long 
    Dim ProcTitle   As String 
    Dim strBuffer   As String 
    Dim strName     As String 
    Dim xlSheet     As Worksheet 
     
    ProcTitle = "Acronym Engine" 
     '
     '           test for acceptable arguements
     '
    If AcroLen < 1 Or AcroLib = "" Or AcroName = "" Then 
        MsgBox "one or more arguements passed to AcronymRand" & vbCrLf & _ 
        "are not valid" & vbCrLf & _ 
        "AcroLen = " & vbTab & AcroLen & vbCrLf & _ 
        "AcroLib = " & vbTab & AcroLib & vbCrLf & _ 
        "AcroName = " & vbTab & AcroName, vbOKOnly + vbCritical, ProcTitle 
        Exit Sub 
    End If 
     
     '       if this is the first time the proc has been called, call the system random
     '       number seed generator
     '
    If Count = 0 Then Randomize 
     '
     '           for each of N words, randomly select a word from the appropriate
     '               column in the work library worksheet
     '
    Set xlSheet = Worksheets(AcroLib) 
    For J = 1 To N 
        strName = "" 
        Count = Count + 1 
        For I = 1 To AcroLen 
            With xlSheet.Range(xlSheet.Cells(1, I), xlSheet.Cells(1000, I)) 
                LR = .Cells.Find("*", .Cells(1), xlFormulas, _ 
                xlWhole, xlByRows, xlPrevious).Row 
                strName = strName & xlSheet.Cells(RandRange(1, LR), I).Text & " " 
            End With 
        Next I 
         '
         '           if # of definitions = 1, then display the definition and exit.  Otherwise
         '               store current definition in strBuffer and continue
         '
        If N = 1 Then 
            MsgBox AcroName & "  # " & Count & " is " & vbCrLf & strName, _ 
            vbOKOnly + vbInformation, ProcTitle 
            GoTo CleanUp 
        End If 
        strBuffer = strBuffer & Count & vbTab & strName & vbCrLf 
    Next J 
    MsgBox vbTab & AcroName & vbCrLf & vbCrLf & strBuffer, _ 
    vbOKOnly + vbInformation, ProcTitle 
CleanUp: 
     '
     '           clean up
     '
    Set xlSheet = Nothing 
End Sub 
 
Sub AcronymCombos(AcroLen, AcroLib) 
     '
     '****************************************************************************************
     '
     '       Title       AcronymCombos
     '       Target Application:  any
     '       Function    determines how many unique acronym definitions are possible
     '       Passed Values:  None
     '           AcroLen   [in, numeric]   length of acronym (and, therefore, # of cols in
     '                                       word library
     '           AcroLib   [in, string]    sheet name containing word library
     '
     '****************************************************************************************
     '
     '
    Dim Combos      As Long 
    Dim I           As Long 
    Dim ProcTitle   As String 
    Dim strBuffer   As String 
    Dim xlLastRow   As Long 
    Dim xlSheet     As Worksheet 
     
     
    ProcTitle = "Acronym Engine" 
     '
     '           test for acceptable arguements
     '
    If AcroLen < 1 Or AcroLib = "" Then 
        MsgBox "one or more arguements passed to AcronymCombos" & vbCrLf & _ 
        "are not valid" & vbCrLf & _ 
        "AcroLen = " & vbTab & AcroLen & vbCrLf & _ 
        "AcroLib = " & vbTab & AcroLib & vbCrLf, vbOKOnly + vbCritical, ProcTitle 
        Exit Sub 
    End If 
     
     '
     '           loop through each col in word name sheet; product of # items in
     '               each col is the # of unique combinations
     '
    Set xlSheet = Worksheets(AcroLib) 
    Combos = 1 
    For I = 1 To AcroLen 
        With xlSheet.Range(xlSheet.Cells(1, I), xlSheet.Cells(1000, I)) 
            xlLastRow = .Cells.Find("*", .Cells(1), xlFormulas, _ 
            xlWhole, xlByRows, xlPrevious).Row 
        End With 
        Combos = Combos * xlLastRow 
        strBuffer = strBuffer & "# names in col " & I & " =" & vbTab & _ 
        xlLastRow & vbCrLf 
    Next I 
    MsgBox "AcronymCombos" & vbCrLf & vbCrLf & strBuffer & vbCrLf & _ 
    "# unique combinations = " & Combos, vbInformation 
     
CleanUp: 
     '
     '           clean up
     '
    Set xlSheet = Nothing 
     
End Sub 
 
Sub AcronymLibScan(AcroLen, AcroLib) 
     '
     '****************************************************************************************
     '
     '       Title       AcronymLibScan
     '       Target Application:  any
     '       Function    scans acronym wrod library for duplicates
     '       Passed Values:  (
     '           AcroLen   [in, numeric]   length of acronym
     '           AcroLib   [in, string]    sheet name containing word library
     '       Public/Private Variables used: NONE
     '
     '****************************************************************************************
     '
     '
    Dim Dups        As Long 
    Dim I           As Long 
    Dim J           As Long 
    Dim K           As Long 
    Dim ProcTitle   As String 
    Dim strBuffer   As String 
    Dim xlLastRow   As Long 
    Dim xlSheet     As Worksheet 
     
    ProcTitle = "Acronym Engine" 
     '
     '           test for acceptable arguements
     '
    If AcroLen < 1 Or AcroLib = "" Then 
        MsgBox "one or more arguements passed to AcronymLibScan" & vbCrLf & _ 
        "are not valid" & vbCrLf & _ 
        "AcroLen = " & vbTab & AcroLen & vbCrLf & _ 
        "AcroLib = " & vbTab & AcroLib & vbCrLf, vbOKOnly + vbCritical, ProcTitle 
        Exit Sub 
    End If 
     '
     '           loop through each col in word name sheet; use bubble approach approach
     '               to examine for dups in each col
     '
    Set xlSheet = Worksheets(AcroLib) 
    For I = 1 To AcroLen 
        With xlSheet.Range(xlSheet.Cells(1, I), xlSheet.Cells(1000, I)) 
            xlLastRow = .Cells.Find("*", .Cells(1), xlFormulas, _ 
            xlWhole, xlByRows, xlPrevious).Row 
        End With 
        For J = 1 To xlLastRow - 1 
            For K = J + 1 To xlLastRow 
                If xlSheet.Cells(J, I) = xlSheet.Cells(K, I) Then 
                    Dups = Dups + 1 
                    strBuffer = strBuffer & I & vbTab & J & vbTab & K & vbTab & _ 
                    xlSheet.Cells(J, I) & vbCrLf 
                End If 
            Next K 
        Next J 
    Next I 
    If Dups = 0 Then 
        MsgBox "Scan of " & AcroLib & " complete.  No dups found", vbInformation 
    Else 
        MsgBox "Scan of " & AcroLib & " complete.  " & Dups & " dups found" & _ 
        vbCrLf & vbCrLf & _ 
        "Col" & vbTab & "Row1" & vbTab & "Row2" & vbTab & "Text" & vbCrLf & _ 
        strBuffer, vbInformation 
    End If 
CleanUp: 
     '
     '           clean up
     '
    Set xlSheet = Nothing 
     
End Sub 
 
Function RandRange(I, J) As Long 
     '
     '****************************************************************************************
     '
     '       Title       RandRange
     '       Target Application:  any
     '       Function    generates a random integer value from the range [I,J]
     '       Passed Values:  (all inputs)
     '           I   [in, numeric]   lower limit
     '           J   [in, numeric]   upper limit
     '
     '****************************************************************************************
     '
     '
    RandRange = I + Rnd() * (J - I) 
    If RandRange < I Then RandRange = I 
    If RandRange > J Then RandRange = J 
     
End Function

How to use:

  1. Copy the above code.
  2. Open any workbook.
  3. Press Alt + F11 to open the Visual Basic Editor (VBE).
  4. In the left side window, select the target spreadsheet [it will likely be called VBAProject(name.xls) where name is the name of the spreadsheet]
  5. Select an existing code module for the target worksheet; or from the Insert Menu, choose Insert | Module.
  6. Paste the code into the right-hand code window.
  7. Close the VBE, save the file if desired.
  8. See ?Test The Code? below
 

Test the code:

  1. open the example
  2. click on either YELLOW command button.
  3. The orange command buttons examine the word library for # of possible combinations and scan the library for duplicates
  4. NOTE: the current library is alphbetized, but there is really no reason to do that other than to make things a little easier for humans to read.
 

Sample File:

CMA.zip 29.14KB 

Approved by mdmackillop


This entry has been viewed 309 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2020 VBA Express