I'm working on modernizing Rosetta Code's infrastructure. Starting with communications. Please accept this time-limited open invite to RC's Slack.. --Michael Mol (talk) 20:59, 30 May 2020 (UTC)

# User:Klever

 My Favorite Languages Language Proficiency VBA Active BASIC Somewhat Rusty Fortran Stuck in Fortran 77, WATFOR, WATFIV etc. Pascal Rusty PHP Learning MATLAB Learning JavaScript Semi-Active SQL Semi-Active APL is way back

# VBA Examples

Some nontrivial VBA Examples (to be moved).

In MS Office program (Word, Excel, Access...): open the Visual Basic window. Paste the code in a module. Execute it by typing a suitable command in the Immediate Window. Output will be directed to the Immediate Window unless stated otherwise...

## Dijkstra algorithm

` 'Dijkstra globalsConst MaxGraph As Integer = 100 'max. number of nodes in graphConst Infinity = 1E+308Dim E(1 To MaxGraph, 1 To MaxGraph) As Double  'the edge costs (Infinity if no edge)Dim A(1 To MaxGraph) As Double                 'the distances calculatedDim P(1 To MaxGraph) As Integer                'the previous/path arrayDim Q(1 To MaxGraph) As Boolean                'the queue  Public Sub Dijkstra(n, start)  'simple implementation of Dijkstra's algorithm  'n = number of nodes in graph  'start = index of start node  'init distances A    For j = 1 To n      A(j) = Infinity    Next j    A(start) = 0  'init P (path) to "no paths" and Q = set of all nodes  For j = 1 To n    Q(j) = True    P(j) = 0  Next j   Do While True 'loop will exit! (see below)  'find node u in Q with smallest distance to start    dist = Infinity    For i = 1 To n      If Q(i) Then        If A(i) < dist Then          dist = A(i)          u = i        End If      End If    Next i    If dist = Infinity Then Exit Do 'no more nodes available - done!    'remove u from Q    Q(u) = False    'loop over neighbors of u that are in Q    For j = 1 To n      If Q(j) And E(u, j) <> Infinity Then        'check if path to neighbor j via u is shorter than current estimated distance to j        alt = A(u) + E(u, j)        If alt < A(j) Then          'yes, replace with new distance and remember "previous" hop on the path          A(j) = alt          P(j) = u        End If      End If    Next j  LoopEnd Sub Public Function GetPath(source, target) As String 'reconstruct shortest path from source to target 'by working backwards from target using the P(revious) array Dim path As String If P(target) = 0 Then   GetPath = "No path" Else   path = ""   u = target   Do While P(u) > 0     path = Format\$(u) & " " & path     u = P(u)   Loop   GetPath = Format\$(source) & " " & path End IfEnd Function  Public Sub DijkstraTest()'main function to solve Dijkstra's algorithm and return shortest path between'a node and every other node in a digraph ' define problem:' number of nodesn = 5' reset connection/cost per edgeFor i = 1 To n  For j = 1 To n    E(i, j) = Infinity  Next j  P(i) = 0Next i' fill in the edge costsE(1, 2) = 10E(1, 3) = 50E(1, 4) = 65E(2, 3) = 30E(2, 5) = 4E(3, 4) = 20E(3, 5) = 44E(4, 2) = 70E(4, 5) = 23E(5, 1) = 6 'Solve it for every nodeFor v = 1 To n  Dijkstra n, v  'Print solution  Debug.Print "From", "To", "Cost", "Path"  For j = 1 To n    If v <> j Then Debug.Print v, j, IIf(A(j) = Infinity, "---", A(j)), GetPath(v, j)  Next j  Debug.PrintNext vEnd Sub `

Output (using the same graph as in the Floyd-Warshall algorithm below):

```DijkstraTest
From          To            Cost          Path
1             2             10           1 2
1             3             40           1 2 3
1             4             60           1 2 3 4
1             5             14           1 2 5

From          To            Cost          Path
2             1             10           2 5 1
2             3             30           2 3
2             4             50           2 3 4
2             5             4            2 5

From          To            Cost          Path
3             1             49           3 4 5 1
3             2             59           3 4 5 1 2
3             4             20           3 4
3             5             43           3 4 5

From          To            Cost          Path
4             1             29           4 5 1
4             2             39           4 5 1 2
4             3             69           4 5 1 2 3
4             5             23           4 5

From          To            Cost          Path
5             1             6            5 1
5             2             16           5 1 2
5             3             46           5 1 2 3
5             4             66           5 1 2 3 4
```

## Floyd-Warshall algorithm

The Floyd algorithm or Floyd-Warshall algorithm finds the shortest path between all pairs of nodes in a weighted, directed graph. It is an example of dynamic programming.

Usage: fill in the number of nodes (n) and the edge distances or costs in sub Floyd or in sub FloydWithPaths. Then run "Floyd" or "FloydWithPaths".

Floyd: this sub prints the lengths or costs of the shortest paths but not the paths themselves

FloydWithPaths: this sub prints the lengths and the nodes along the paths

` Option Compare Database 'Floyd globalsConst MaxGraph As Integer = 100 'max. number of vertices in graphConst Infinity = 1E+308Dim E(1 To MaxGraph, 1 To MaxGraph) As DoubleDim A(1 To MaxGraph, 1 To MaxGraph) As DoubleDim Nxt(1 To MaxGraph, 1 To MaxGraph) As Integer Public Sub SolveFloyd(n)  'Floyd's algorithm: all-pairs shortest-paths cost  'returns the cost (distance) of the least-cost (shortest) path  'between all pairs in a labeled directed graph  'note: this sub returns only the costs, not the paths!  '  'inputs:  ' n : number of vertices (maximum value is maxGraph)  ' E(i,j) : cost (length,...) of edge from i to j or "Infinity" if no edge between i and j  'output:  ' A(i,j): minimal cost for path from i to j  'constant:  ' Infinity : very large number   For i = 1 To n    For j = 1 To n      If E(i, j) <> Infinity Then A(i, j) = E(i, j) Else A(i, j) = Infinity    Next j    A(i, i) = 0  Next i  For k = 1 To n    For i = 1 To n      For j = 1 To n        If A(i, k) + A(k, j) < A(i, j) Then A(i, j) = A(i, k) + A(k, j)      Next j    Next i  Next kEnd Sub Public Sub SolveFloydWithPaths(n)  'cf. SolveFloyd, but here we  'use matrix "Nxt" to store information about paths  For i = 1 To n    For j = 1 To n      If E(i, j) <> Infinity Then A(i, j) = E(i, j) Else A(i, j) = Infinity    Next j    A(i, i) = 0  Next i  For k = 1 To n    For i = 1 To n      For j = 1 To n        If A(i, k) + A(k, j) < A(i, j) Then          A(i, j) = A(i, k) + A(k, j)          Nxt(i, j) = k        End If      Next j    Next i  Next kEnd Sub Public Function GetPath(i, j) As String 'recursively reconstruct shortest path from i to j using A and Nxt If A(i, j) = Infinity Then   GetPath = "No path!" Else   tmp = Nxt(i, j)   If tmp = 0 Then     GetPath = " " 'there is an edge from i to j   Else     GetPath = GetPath(i, tmp) & Format\$(tmp) & GetPath(tmp, j)   End If End IfEnd Function Public Sub Floyd()'main function to apply Floyd's algorithm'see description in wp:en:Floyd-Warshall algorithm ' define problem:' number of vertices?n = 5' reset connection/cost per edge matrixFor i = 1 To n  For j = 1 To n    E(i, j) = Infinity  Next jNext i' fill in the edge costsE(1, 2) = 10E(1, 3) = 50E(1, 4) = 65E(2, 3) = 30E(2, 5) = 4E(3, 4) = 20E(3, 5) = 44E(4, 2) = 70E(4, 5) = 23E(5, 1) = 6 'Solve itSolveFloyd n 'Print solution'note: for large graphs the output may be too large for the Immediate panel'in that case you could send the output to a text fileDebug.Print "From", "To", "Cost"For i = 1 To n  For j = 1 To n    If i <> j Then Debug.Print i, j, IIf(A(i, j) = Infinity, "No path!", A(i, j))  Next jNext iEnd Sub Public Sub FloydWithPaths()'main function to solve Floyd's algorithm and return shortest path between'any two vertices ' define problem:' number of vertices?n = 5' reset connection/cost per edge matrixFor i = 1 To n  For j = 1 To n    E(i, j) = Infinity    Nxt(i, j) = 0  Next jNext i' fill in the edge costsE(1, 2) = 10E(1, 3) = 50E(1, 4) = 65E(2, 3) = 30E(2, 5) = 4E(3, 4) = 20E(3, 5) = 44E(4, 2) = 70E(4, 5) = 23E(5, 1) = 6 'Solve itSolveFloydWithPaths n 'Print solution'note: for large graphs the output may be too large for the Immediate panel'in that case you could send the output to a text fileDebug.Print "From", "To", "Cost", "Via"For i = 1 To n  For j = 1 To n    If i <> j Then Debug.Print i, j, IIf(A(i, j) = Infinity, "---", A(i, j)), GetPath(i, j)  Next jNext iEnd Sub `

Output:

```Floyd
From          To            Cost
1             2             10
1             3             40
1             4             60
1             5             14
2             1             10
2             3             30
2             4             50
2             5             4
3             1             49
3             2             59
3             4             20
3             5             43
4             1             29
4             2             39
4             3             69
4             5             23
5             1             6
5             2             16
5             3             46
5             4             66

FloydWithPaths
From          To            Cost          Via
1             2             10
1             3             40            2
1             4             60            2 3
1             5             14            2
2             1             10            5
2             3             30
2             4             50            3
2             5             4
3             1             49            4 5
3             2             59            4 5 1
3             4             20
3             5             43            4
4             1             29            5
4             2             39            5 1
4             3             69            5 1 2
4             5             23
5             1             6
5             2             16            1
5             3             46            1 2
5             4             66            1 2 3
```

## KWIC index

` 'KWIC index'assumptions:' - all titles and catalog numbers can be held in an array in main memory' - disregard punctuation in titles' - the KWIC index itself may be too large for main memory - do not store it in memory' - the KWIC index consists of one line per title/keyword combination and consists of:'   - the catalog number'   - the title with the keyword centered in a line of given length (e.g. 80 or 120)'  (constant-width font assumed)'   note: long titles may be truncated at the beginning or the end of the line'globalsConst MAXKEYS = 20       'max. number of keywords in a titleConst STOPWORDS = "a an and by for is it of on or the to with " 'that last space is needed!Dim title() As String    'list of titles to be included in KWIC indexDim catno() As Integer   'list of catalog numbersDim ntitle As Integer    'number of titlesDim index() As Integer   'holds title number and position of keyword in titleDim nkeys As Long        'total number of keywords foundSub ReadTitles()' read or - in this case - set the titles and catalog numbersntitle = 10ReDim title(1 To ntitle)ReDim catno(1 To ntitle)  title(1) = "Microsoft Visio 2003 User's Guide"  title(2) = "Microsoft Office Excel 2003 Inside Out"  title(3) = "Mastering Excel 2003 Programming with VBA"  title(4) = "Excel 2003 Formulas"  title(5) = "Excel for Scientists and Engineers"  title(6) = "Excel 2003 VBA Programmer's Reference"  title(7) = "Automated Data Analysis Using Excel"  title(8) = "Beginning Excel: What-if Data Analysis Tools"  title(9) = "How to do Everything with Microsoft Office Excel 2003"  title(10) = "Data Analysis Using SQL and Excel"  catno(1) = 10  catno(2) = 13  catno(3) = 3435  catno(4) = 987  catno(5) = 1010  catno(6) = 1244  catno(7) = 709  catno(8) = 9088  catno(9) = 33  catno(10) = 7733End Sub Function IsStopword(aword) As Boolean'search for aword in stopword list'add an extra space to avoid ambiguityIsStopword = InStr(STOPWORDS, LCase(aword) & " ") > 0End Function Sub ProcessTitles()'find positions of keywords in titles, store in index array'Note: we cannot use Split here because that function doesn't return'the positions of the words it findsnkeys = 0For i = 1 To ntitle  atitle = title(i) & " " 'add extra space as sentinel  p1 = 1  Do While p1 <= Len(atitle)    'find next word:    'a) find next non-space    While Mid\$(atitle, p1, 1) = " ": p1 = p1 + 1: Wend    'b) extend word    p2 = p1    While Mid\$(atitle, p2, 1) <> " ": p2 = p2 + 1: Wend    aword = Mid\$(atitle, p1, p2 - p1)    'for now we assume there is no punctuation, i.e. no words    'in parentheses, brackets or quotation marks    If Not IsStopword(aword) Then      'remember position of this keyword      'we probably should check for overflow (too many keywords) here!      nkeys = nkeys + 1      index(nkeys, 1) = i      index(nkeys, 2) = p1    End If    'continue searching    p1 = p2 + 1  LoopNext iEnd Sub Function Shift(aString, pos)'return shifted string (part beginning at position "pos" followed by part before it)  Shift = Mid\$(aString, pos) & " " & Left\$(aString, pos - 1)End Function Sub SortTitles()  ' sort the index() array to represent shifted titles in alphabetical order  ' more efficient sorting algorithms can be applied here...  switched = True  Do While switched    'scan array for two shifted strings in the wrong order and swap    '(swap the index entries, not the strings)    'use case-insensitive compare    switched = False    For i = 1 To nkeys - 1      string1 = LCase(Shift(title(index(i, 1)), index(i, 2)))      string2 = LCase(Shift(title(index(i + 1, 1)), index(i + 1, 2)))      If string2 < string1 Then 'swap        For j = 1 To 2          temp = index(i, j)          index(i, j) = index(i + 1, j)          index(i + 1, j) = temp        Next        switched = True      End If    Next i  LoopEnd Sub Sub PrintKWIC(linelength)'print the KWIC index  spaces = Space(linelength / 2)  Debug.Print "Cat. number", "|"; Space((linelength - 10) / 2); "KWIC string"  Debug.Print String(linelength + 15, "-")  For i = 1 To nkeys    atitle = title(index(i, 1))    pos = index(i, 2)    'create shifted string so that keyword is centered in the line    part2 = Mid\$(atitle, pos)    part1 = Right\$(spaces & Left\$(atitle, pos - 1), linelength / 2)    kwicstring = Right\$(part1, linelength / 2) & Left\$(part2, linelength / 2)    Debug.Print catno(index(i, 1)), "|"; kwicstring  NextEnd Sub Sub KWIC()  'main program for KWIC index  ReadTitles  'set array  ReDim index(ntitle * MAXKEYS, 2)  'index(.,1) is title nr.  'index(.,2) is keyword position in title  ProcessTitles  SortTitles  PrintKWIC 80 'argument is the length of the KWIC lines (excluding catalog numbers)End Sub `

Output (note that some titles are truncated at the start or the end. An improvement could be to wrap these titles around if there is room on the other end):

```kwic
Cat. number   |                                   KWIC string
-----------------------------------------------------------------------------------------------
987          |                                  Excel 2003 Formulas
33           | Everything with Microsoft Office Excel 2003
13           |                 Microsoft Office Excel 2003 Inside Out
3435         |                        Mastering Excel 2003 Programming with VBA
10           |                        Microsoft Visio 2003 User's Guide
1244         |                                  Excel 2003 VBA Programmer's Reference
9088         |          Beginning Excel: What-if Data Analysis Tools
709          |                         Automated Data Analysis Using Excel
7733         |                                   Data Analysis Using SQL and Excel
709          |                                        Automated Data Analysis Using Excel
9088         |                                        Beginning Excel: What-if Data Analysis T
9088         |               Beginning Excel: What-if Data Analysis Tools
709          |                              Automated Data Analysis Using Excel
7733         |                                        Data Analysis Using SQL and Excel
33           |                                 How to do Everything with Microsoft Office Exce
1010         |               Excel for Scientists and Engineers
33           |                              How to do Everything with Microsoft Office Excel 2
987          |                                        Excel 2003 Formulas
33           | to do Everything with Microsoft Office Excel 2003
13           |                       Microsoft Office Excel 2003 Inside Out
3435         |                              Mastering Excel 2003 Programming with VBA
1244         |                                        Excel 2003 VBA Programmer's Reference
709          |          Automated Data Analysis Using Excel
7733         |            Data Analysis Using SQL and Excel
1010         |                                        Excel for Scientists and Engineers
9088         |                              Beginning Excel: What-if Data Analysis Tools
987          |                             Excel 2003 Formulas
10           |            Microsoft Visio 2003 User's Guide
33           |                                        How to do Everything with Microsoft Offi
13           |            Microsoft Office Excel 2003 Inside Out
3435         |                                        Mastering Excel 2003 Programming with VB
33           |              How to do Everything with Microsoft Office Excel 2003
13           |                                        Microsoft Office Excel 2003 Inside Out
10           |                                        Microsoft Visio 2003 User's Guide
33           |    How to do Everything with Microsoft Office Excel 2003
13           |                              Microsoft Office Excel 2003 Inside Out
13           |     Microsoft Office Excel 2003 Inside Out
1244         |                         Excel 2003 VBA Programmer's Reference
3435         |                   Mastering Excel 2003 Programming with VBA
1244         |            Excel 2003 VBA Programmer's Reference
1010         |                              Excel for Scientists and Engineers
7733         |                    Data Analysis Using SQL and Excel
9088         | Beginning Excel: What-if Data Analysis Tools
10           |                   Microsoft Visio 2003 User's Guide
709          |                Automated Data Analysis Using Excel
7733         |                          Data Analysis Using SQL and Excel
3435         |  Mastering Excel 2003 Programming with VBA
1244         |                             Excel 2003 VBA Programmer's Reference
10           |                              Microsoft Visio 2003 User's Guide
9088         |                       Beginning Excel: What-if Data Analysis Tools
```

## Hailstone sequence

` Public Function Hailstone(aNumber As Long, Optional Printit As Boolean = False) As Long'return length of Hailstone sequence for aNumber'if optional argument Printit is true, print the sequence in the Immediate windowDim nSteps As LongConst NumbersPerLine = 10 'when printing, start a new line after this much numbers nSteps = 1If Printit Then Debug.Print aNumber,While aNumber <> 1  If aNumber Mod 2 = 0 Then aNumber = aNumber / 2 Else aNumber = 3 * aNumber + 1  nSteps = nSteps + 1  If Printit Then Debug.Print aNumber,  If Printit And (nSteps Mod NumbersPerLine = 0) Then Debug.PrintWendIf Printit Then Debug.Print "(Length:"; nSteps; ")"Hailstone = nStepsEnd Function Public Sub HailstoneTest()Dim theNumber As LongDim theSequenceLength As LongDim SeqLength As LongDim i as Long 'find and print the Hailstone sequence for 27 (note: the whole sequence, not just the first four and last four items!)Debug.Print "Hailstone sequence for 27:"theNumber = Hailstone(27, True) 'find the longest Hailstone sequence for numbers less than 100000.theSequenceLength = 0For i = 2 To 99999  SeqLength = Hailstone(i)  If SeqLength > theSequenceLength Then    theNumber = i    theSequenceLength = SeqLength  End IfNext iDebug.Print theNumber; "has the longest sequence ("; theSequenceLength; ")."End Sub `

Output:

```HailstoneTest
Hailstone sequence for 27:
27            82            41            124           62            31            94            47            142           71
214           107           322           161           484           242           121           364           182           91
274           137           412           206           103           310           155           466           233           700
350           175           526           263           790           395           1186          593           1780          890
445           1336          668           334           167           502           251           754           377           1132
566           283           850           425           1276          638           319           958           479           1438
719           2158          1079          3238          1619          4858          2429          7288          3644          1822
911           2734          1367          4102          2051          6154          3077          9232          4616          2308
1154          577           1732          866           433           1300          650           325           976           488
244           122           61            184           92            46            23            70            35            106
53            160           80            40            20            10            5             16            8             4
2             1            (Length: 112 )
77031 has the longest sequence ( 351 ).
```