The above picture shows you January 2017, simply enter the project name in column A and the hours in cell range B5:AF32. Row 4 contains dates for January, row 3 the weekdays and row 2 the week numbers. Saturday and Sundays are colored grey.

The Summary sheet, see picture below, contains all projects entered in all month sheets and a total, both for the month and project. A quite large array formula extracts all project names in column B, you don't need to do that manually.

A simple SUMIF function sums the values from each monthly sheet, excel takes care of that too. There is no vba in this workbook, you can find the download link below.

If you change the year on sheet "Summary" you will notice that the monthly sheets change accordingly, you don't need to change weekdays, week number or color weekends on each sheet, excel will do it for you.

Any suggestions for improvement?

]]>

A regular expression is a sequence of characters that define a search pattern, according to Wikipedia.

This is the custom function I am using to extract cell references from a formula.

Function ExtractCellRefs(c As Range) As String regexpattern = "" With CreateObject("vbscript.regexp") .Global = True .MultiLine = True .IgnoreCase = False .Pattern = regexpattern Set Results = .Execute(c.Formula) End With If Results.Count <> 0 Then With Results For d = 0 To .Count - 1 Rstr = Rstr & .Item(d) & "," Next End With ExtractCellRefs = Left(Rstr, Len(Rstr) - 1) Else ExtractCellRefs = "No Matches" End If End Function

The tricky part is the regular expression and I am a beginner at this, feel free to simplify my expression.

A cell reference can be anything from A1 to XFD1048576 so to match that the reg exp becomes:

[A-Z]{1,3}[0-9]{1,7}

[A-Z] matches any upper case letter from A to Z.

[A-Z]{1,3} matches 1 or up to 3 lower and upper case letters from A to Z. Example, XFD1048576 contains three letters.

[0-9]{1,7} matches 1 or more up to 7 digits from 0 to 9. Example, XFD1048576 contains 7 digits.

A cell reference can also be absolute or relative or both and the $ sign tells which it is.

\$?[A-Z]{1,3}\$?[0-9]{1,7}

\ (backslash) escapes the character that follows

\$ allows us to use the character $, if I had not used the \ (backslash) $ (dollar sign) had been taken for a match at end of string, I don't want that to happen.

\$? the question mark matches zero or one of the pattern defined before it, in this case $ (dollar sign)

The picture below shows the matches for above expression \$?[A-Z]{1,3}\$?[0-9]{1,7}

It also works for this simple formula: =SUM(XFD1048576, $A$1,A$1,$A1), it returns these cell references: XFD1048576,$A$1,A$1,$A1

**Cell reference to a cell range**

The above regular expression finds only cell refs to a single cell, how do we find a solution to that?

A cell ref to a single cell looks like this =A1, a cell ref to a cell range may look like this =A1:C3

\$?[A-Z]{1,3}\$?[1-9]{1,7}(:\$?[A-Z]{1,3}\$?[1-9]{1,7})?

The new part is

(:\$?[A-Z]{1,3}\$?[0-9]{1,7})?

( (parentheses) groups an expression

: a cell ref to a cell range contains a colon :

\$?[A-Z]{1,3}\$?[0-9]{1,7} is the same as before, it matches letters and digits

(:\$?[A-Z]{1,3}\$?[0-9]{1,7}) the parentheses groups the expression

(:\$?[A-Z]{1,3}\$?[0-9]{1,7})? the question mark matches zero or one of the pattern defined before it, in this case the group

**Cell references to other sheets**

A cell reference to another sheet always ends with a ! (exclamation mark), the question mark matches zero or one of the pattern defined before it, in this case the ! (exclamation mark)

This is a new group so I am leaving out the previous expression for now, I will add it later. The regular expression is now !?

The sheet name may have lower and upper letters from A to Z and also numbers 0 to 9, the regular expression is [a-zA-Z0-9]{1,99}!?

If there is a blank space in the sheet name excel automatically surrounds the sheet name with two ' (apostrophe character), the expression becomes '?[a-zA-Z0-9]{1,99}'?!?

\s is any space character, this is what we have now '?[a-zA-Z0-9\s]{1,99}'?!?

'? the question mark matches zero or one of the pattern defined before it, in this case the ' (apostrophe character)

**Cell references to other workbooks**

There may also be cell references to other workbooks, it would be nice to find them as well.

A reference to a cell range in another workbook has the workbook name surrounded by these characters [].

('?[a-zA-Z0-9\s\[\]]{1,99})?'?!? , \ (backslash) escapes the character that follows in this case \[\]

The file name has a dot between the file name and the extension, ('?[a-zA-Z0-9\s\[\]\.]{1,99})?'?!?

The final expression is

('?[a-zA-Z0-9\s\[\]\.]{1,99})?'?!?\$?[A-Z]{1,3}\$?[0-9]{1,7}(:\$?[A-Z]{1,3}\$?[0-9]{1,7})?

Can it be made smaller?

I am sure there are characters allowed in a filename or sheet name that I have not considered in this post but I believe it will be easy to add those as well.

This does not take care of named ranges in a formula but it would not be hard to build a list of named ranges and then check if the formula contains named ranges.

Hello Oscar,

What code is needed to cause cells in Columns F - I to fill with the contents of Columns C - E when a cell in Column B includes a numeric value?

What code is needed to cause cells in Columns F - I to fill with the contents of Columns C - E when a cell in Column B includes a numeric value?

**Answer:**

The data set above contains random characters, some of the cells in column B contains numeric values, as well.

**Array formula in cell F2:**

=INDEX($B$2:$E$6, SMALL(IF(MMULT(IFERROR(SEARCH({1, 2, 3, 4, 5, 6, 7, 8, 9, 0}, $B$2:$B$6), 0), ROW($A$1:$A$10)), MATCH(ROW($B$2:$B$6), ROW($B$2:$B$6)), ""), ROWS($A$1:A1)), COLUMNS($A$1:A1))

- Copy formula above
- Doubleclick on cell F2
- Paste formula
- Press and hold CTRL + SHIFT
- Press Enter

If you did this correctly, the formula in the formula bar now begins with a curly bracket and ends with a curly bracket, like this: {=formula}

Don't enter these curly brackets yourself, they will appear if you did the above steps.

Copy cell F2 and paste to cell range F2:I6.

**Step 1 - Look for values in a cell range**

SEARCH({1, 2, 3, 4, 5, 6, 7, 8, 9, 0}, $B$2:$B$6)

becomes

SEARCH({1, 2, 3, 4, 5, 6, 7, 8, 9, 0}, {"ab12"; "abc"; "def"; "a21b"; "cde"})

and returns this array:

{3, 4, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!; #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!; #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!; 3, 2, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!; #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!}

**Step 2 - Remove errors**

IFERROR(SEARCH({1, 2, 3, 4, 5, 6, 7, 8, 9, 0}, $B$2:$B$6), 0)

becomes

IFERROR({3, 4, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!; #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!; #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!; 3, 2, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!; #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!, #VALUE!}, 0)

and returns

{3, 4, 0, 0, 0, 0, 0, 0, 0, 0; 0, 0, 0, 0, 0, 0, 0, 0, 0, 0; 0, 0, 0, 0, 0, 0, 0, 0, 0, 0; 3, 2, 0, 0, 0, 0, 0, 0, 0, 0; 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}

**Step 3 - Return the matrix product of two arrays**

MMULT(IFERROR(SEARCH({1, 2, 3, 4, 5, 6, 7, 8, 9, 0}, $B$2:$B$6), 0), ROW($A$1:$A$10))

becomes

MMULT({3, 4, 0, 0, 0, 0, 0, 0, 0, 0; 0, 0, 0, 0, 0, 0, 0, 0, 0, 0; 0, 0, 0, 0, 0, 0, 0, 0, 0, 0; 3, 2, 0, 0, 0, 0, 0, 0, 0, 0; 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, ROW($A$1:$A$10))

becomes

MMULT({3, 4, 0, 0, 0, 0, 0, 0, 0, 0; 0, 0, 0, 0, 0, 0, 0, 0, 0, 0; 0, 0, 0, 0, 0, 0, 0, 0, 0, 0; 3, 2, 0, 0, 0, 0, 0, 0, 0, 0; 0, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {1;2;3;4;5;6;7;8;9;10})

and returns

{11;0;0;7;0}

**Step 4 - Check whether a condition is met**

IF(MMULT(IFERROR(SEARCH({1, 2, 3, 4, 5, 6, 7, 8, 9, 0}, $B$2:$B$6), 0), ROW($A$1:$A$10)), MATCH(ROW($B$2:$B$6), ROW($B$2:$B$6)), "")

becomes

IF({11;0;0;7;0}, MATCH(ROW($B$2:$B$6), ROW($B$2:$B$6)), "")

becomes

IF({11;0;0;7;0}, {1;2;3;4;5}, "")

and returns {1;"";"";4;""}

**Step 5 - Return the k-th smallest value in array**

SMALL(IF(MMULT(IFERROR(SEARCH({1, 2, 3, 4, 5, 6, 7, 8, 9, 0}, $B$2:$B$6), 0), ROW($A$1:$A$10)), MATCH(ROW($B$2:$B$6), ROW($B$2:$B$6)), ""), ROWS($A$1:A1))

becomes

SMALL({1;"";"";4;""}, ROWS($A$1:A1))

becomes

SMALL({1;"";"";4;""}, 1)

and returns 1.

**Step 6 - Return a value of the cell at the intersection of a particular row and column**

=INDEX($B$2:$E$6, SMALL(IF(MMULT(IFERROR(SEARCH({1, 2, 3, 4, 5, 6, 7, 8, 9, 0}, $B$2:$B$6), 0), ROW($A$1:$A$10)), MATCH(ROW($B$2:$B$6), ROW($B$2:$B$6)), ""), ROWS($A$1:A1)), COLUMNS($A$1:A1))

becomes

=INDEX($B$2:$E$6, 1, COLUMNS($A$1:A1))

becomes

=INDEX($B$2:$E$6, 1, 1)

becomes

=INDEX({"ab12", "PEN", "YPT", "KVF"; "abc", "ZLZ", "KIK", "HQX"; "def", "CJI", "YMI", "STC"; "a21b", "TQW", "XHA", "UBM"; "cde", "YZX", "GLT", "TED"}, 1, 1)

and returns ab12 in cell F2.

Filter records containing a value.xlsx

If you rather want to use an excel table filter, follow these instructions

]]>? (question mark) - Matches any single character

* (asterisk) - Matches zero or more characters

# (number or hash sign) - Any single digit

A1A* - You can also use a string combined with characters above to build a pattern. This matches a string beginning with or equals A1A.

[abc] - Characters enclosed in brackets allows you to match any single character in the string.[!abc] - The exclamation mark (!) matches any single character not in the string.

[A-Z] - The hyphen lets you specify a range of characters.

Add *Option compare binary* or *Option compare text *before any macros or custom functions in you code module to change how string comparisons are made.

The default setting is *Option compare binary. *Use *Option compare text *to make the comparison case-insensitive but put the code in a separate module so other macros/functions are not affected.

To learn more, read this article: Option Compare Statement

The LIKE operator returns a boolean value, TRUE or FALSE depending on if the pattern is a match or not.

This simple custom function lets you specify a pattern and compare it to a cell value. If there is a match, the function returns TRUE. If not, FALSE.

Function Compare(c As Range, pttrn As String) As Boolean Compare = c Like pttrn End Function

Copy the code above and paste it to a code module in the VB Editor, if you want to use it.

The picture below demonstrates the custom function above. It takes the string in cell A2 and compares it to the pattern in cell B2.

A question mark (?) matches any single character.

Value in cell A2 ABC matches A?C, TRUE is returned in cell D2.

Value in cell A3 ABCD does not match pattern A?D. BC are two characters, a question mark matches any single character. FALSE is returned in cell D3.

Value ABCD matches ?BC? and TRUE is returned in cell D4.

The pattern tells you that the first three characters must be AAA and then the * (asterisk) matches zero or more characters. AAAC is a match to pattern AAA* and the custom function returns TRUE in cell D2.

aaa* does not match pattern AAAC. aaa is not equal to AAA. LIKE operator is case sensitive unless you change settings to Option Compare Text.

(*) matches zero or more characters, DDC23E matches DD*E.

# matches a single digit. To match multiple digits use multiple #.

123 matches 12#, TRUE is returned in cell D2.

123 does not match 1#, number sign matches any single digit.

123 matches #2#.

The following three examples use asterisks, question marks and number signs combined.

Remember brackets match any single character you specify. A hyphen lets you compare a range of characters.

The following custom function allows you to extract cell values using the LIKE operator.

**Array fomula in cell C2:C6:**

=SearchPattern(A2:A15,B2)

Function SearchPattern(c As Range, pttrn As String) Dim d as String For Each cell In c If cell Like pttrn Then d = d & cell & "," Next cell SearchPattern = Application.Transpose(Split(d, ",")) End Function

This custom function allows you to look for a pattern in a column and return the corresponding value in another column.

**Array fomula in cell D2:D6:**

=SearchCol(A2:A15,B2:B15,C2)

Function SearchCol(b As Range, c As Range, pttrn As String) Dim a As Long, d as String a = b.Cells.CountLarge For i = 1 To a If b.Cells(i) Like pttrn Then d = d & c.Cells(i) & "," Next i SearchCol = Application.Transpose(Split(d, ",")) End Function

You can use the question (?) mark and asterisk (*) in many excel functions.

If you need to use even more complicated patterns excel allows you to use regular expressions, see this thread:

How to use Regular Expressions (Regex) in Microsoft Excel both in-cell and loops

The picture above shows a weekly stock bar chart of Microsoft and Caterpillar. One bar shows you the highest price and the lowest price during that specific week, it also shows the closing price which is the price of the last deal done that week.

- Rearrange columns like this: high, low and close

- Select columns High, Low and close
- Go to tab "Insert" on the ribbon
- Click "Other Charts" and then "High-Low-Close"

- A chart is inserted on your active sheet

- Right click on chart and click on "Select Data..."
- Click Edit button below Horizontal (Category) Axis Labels
- Select your date range

- Click OK button twice

- Right click on chart again
- Click on "Select Data"
- Click on "Add" button below Legend Entries (Series)
- Select High column for the other stock you want plotted

- Click OK twice
- Select the chart
- Go to tab "Layout" on the ribbon
- Select series 4

- Click "Format Selection" below Series 4
- Change to "Secondary Axis"

- Click Close
- Right click on chart again and click on "Select Data..."
- Add Low and Close series
- Go to tab "Layout" on the ribbon
- Select "Series 4"
- Click on "Lines" button and then "High-Low" Lines

- Select "Series 6" (Close)
- Click "Format Selection"
- Go to "Marker Options", choose built-in marker type and the sixth symbol from the top.

- Select size 3
- Go to "Marker Line Color", select "Solid Line" and finally pick a color. I chose dark blue.

- Select "High Low Lines 2"

- Select "Solid Line" and select a color

- Click Close

You now know how to change the color of high low lines and the closing line. Change the line color of all series (High, Low and Close) on the primary axis.

I chose black. Now delete the secondary axis and remove entries on the legend except "Close" and "Series 6". Change the name of series "Close" to Microsoft and "Series 6" to Caterpillar.

How easy is it to modify this for recurring tasks (weekdays, weekly, monthly, quarterly and yearly) and maybe show a monthly view? Times are less important than just showing what is due on what day.

I made a calendar shown below, monthly view. The picture is resized to fit this blog, click to see the original size. This calendar is more advanced than the template I made year 2011.

The form next to the calendar allows you to add events. Enter time and event name and then click button "Add".

If there are more events on a single day than can be displayed, the last line tells you ...more.... See picture below for an example.

Select that cell and all events are shown in a table next to the calendar.

You can easily edit or delete an event by clicking a link in column Time, see picture above. The link takes you to the record on sheet "Schedule", see picture below.

Here you can edit or delete the record as you please.

The buttons above the calendar lets you go to next or previous month, there is also a button that takes you to the current month, button "Today"

Days before and after selected month are grayed out. Current day is highlighted orange. The following picture shows you this.

The best I could do is creating a formula that calculates the upcoming recurring event. Events after that are not shown until the date has passed.

**Monthly**

Array formula in cell H4:

=IF(DAY(TODAY())>3, DATE(YEAR(TODAY()), MONTH(TODAY())+1, 3)+11/24, DATE(YEAR(TODAY()), MONTH(TODAY()), 3)+11/24)

**Weekly**

Array formula in cell H5:

=TODAY()+IF(WEEKDAY(TODAY())<=3, 3-WEEKDAY(TODAY()), (10-WEEKDAY(TODAY())))+15/24

**Daily**

Array formula:

=TODAY()+17/24

Anyone got a better idea?

This workbook contains macros and a custom function.

]]>- Basic schedule
- Round-robin tournament
- Double round-robin tournament
- Macro
- Download workbook
- How to use custom function

According to wikipedia a round-robin tournament is a competition where all plays all. Excel is a great platform for building a round-robin tounament table and keeping scores.

You can use these custom functions below for creating a table for tennis, soccer, chess, bridge or whatever sport/competition schedule you want. At the very end of this post are instructions on how to use the custom functions. Let's start.

The following vba code creates a schedule where each team plays once against another team.

Function roundrobin(rng As Range) 'Get Digital Help http://www.get-digital-help.com/ 'Define variables Dim tmp() As Variant, k As Long Dim i As Long, j As Long 'ReDimension tmp variable ReDim tmp(1 To (rng.Cells.Count / 2) * (rng.Cells.Count - 1), 1 To 2) k = 1 'Schedule everyone with everyone For i = 1 To rng.Cells.Count For j = i + 1 To rng.Cells.Count tmp(k, 1) = rng.Cells(i) tmp(k, 2) = rng.Cells(j) k = k + 1 Next j Next i 'Return array roundrobin = tmp End Function

As you can see it is not very complicated and the first team has home matches all the time. But if home and away doesn't matter this could useful.

Another bad thing with this custom function is that it doesn't split the schedule into rounds. A team can't play twice in the same round, obviously.

Also if you want the schedule to be somewhat random, this custom function is not for you.

The next custom function takes care of these three issues.

This custom function creates a round-robin tournament. It tries to distribute home and away rounds evenly and teams are randomly placed in the schedule.

Function RoundRobin2(rng As Range) 'This custom function adds a team automatically if the number of teams is uneven. 'Get Digital Help http://www.get-digital-help.com/ Dim tmp() As Variant, k As Long, l As Integer Dim i As Long, j As Long, a As Long, r As Long Dim rngA As Variant, Stemp As Variant, Val As Long Dim res, rngB() As Variant, result As String 'Transfer cell values to an array rngA = rng.Value 'Check if the number of teams are even If rng.Cells.Count Mod 2 = 0 Then rngB = rng.Value l = 0 Else ReDim rngB(1 To UBound(rngA) + 1, 1 To 1) For i = 1 To UBound(rngA) rngB(i, 1) = rngA(i, 1) Next i rngB(UBound(rngB, 1), 1) = "-" l = 1 End If ReDim tmp(1 To ((rng.Cells.Count + l) / 2) * (rng.Cells.Count + l - 1), 1 To 3) 'Randomize array rngB = RandomizeArray1(rngB) Val = (UBound(rngB, 1) / 2) 'Build schedule For i = 2 To UBound(rngB, 1) a = 1 For r = 1 To (UBound(rngB, 1) / 2) tmp(r + Val * (i - 2), 1) = i - 1 If (i - 1) Mod 2 = 1 Then tmp(r + Val * (i - 2), 2) = rngB(a, 1) tmp(r + Val * (i - 2), 3) = rngB(UBound(rngB, 1) - a + 1, 1) Else tmp(r + Val * (i - 2), 2) = rngB(UBound(rngB, 1) - a + 1, 1) tmp(r + Val * (i - 2), 3) = rngB(a, 1) End If a = a + 1 Next r 'switch places for all values except the first one For j = 2 To UBound(rngB, 1) - 1 Stemp = rngB(j, 1) rngB(j, 1) = rngB(j + 1, 1) rngB(j + 1, 1) = Stemp Next j Next i RoundRobin2 = tmp End Function

This user defined function creates a random schedule split into rounds, home and away are also somewhat evenly distributed through the schedule.

This table shows you how many times 6 teams play home and away for the entire tournament.

To make sure every team has as many home as away rounds competitors play each other twice. It is a "double" round-robin tournament. The way it works is all play all twice, once home and once away.

Function doubleroundrobin(rng As Range) 'Get Digital Help http://www.get-digital-help.com/ Dim tmp() As Variant, k As Long, l As Integer Dim i As Long, j As Long, a As Long, r As Long Dim rngA As Variant, Stemp As Variant, Val As Long Dim res, rngB() As Variant, result As String, cc As Long 'Transfer values to an array rngA = rng.Value 'Check if the number of teams are even If rng.Cells.Count Mod 2 = 0 Then rngB = rng.Value l = 0 Else ReDim rngB(1 To UBound(rngA) + 1, 1 To 1) For i = 1 To UBound(rngA) rngB(i, 1) = rngA(i, 1) Next i rngB(UBound(rngB, 1), 1) = "-" l = 1 End If cc = ((rng.Cells.Count + l) / 2) * (rng.Cells.Count + l - 1) ReDim tmp(1 To cc * 2, 1 To 3) 'Randomize array rngB = RandomizeArray1(rngB) Val = (UBound(rngB, 1) / 2) 'Build schedule For i = 2 To UBound(rngB, 1) a = 1 For r = 1 To (UBound(rngB, 1) / 2) tmp(r + Val * (i - 2), 1) = i - 1 If (i - 1) Mod 2 = 1 Then tmp(r + Val * (i - 2), 2) = rngB(a, 1) tmp(r + Val * (i - 2), 3) = rngB(UBound(rngB, 1) - a + 1, 1) Else tmp(r + Val * (i - 2), 2) = rngB(UBound(rngB, 1) - a + 1, 1) tmp(r + Val * (i - 2), 3) = rngB(a, 1) End If a = a + 1 Next r For j = 2 To UBound(rngB, 1) - 1 Stemp = rngB(j, 1) rngB(j, 1) = rngB(j + 1, 1) rngB(j + 1, 1) = Stemp Next j Next i 'Copy schedule and change home to away and vice versa, this makes it a double round-robin tournament For i = cc + 1 To cc * 2 tmp(i, 1) = UBound(rngB, 1) - 1 + tmp(i - cc, 1) tmp(i, 2) = tmp(i - cc, 3) tmp(i, 3) = tmp(i - cc, 2) Next i doubleroundrobin = tmp End Function

Here is a table that shows you teams play as many home as away games.

The macros in the workbook below allows you to create a match schedule. Go to sheet Macro and follow instructions.

Add teams or players to column A, then click "Round-robin tournament" button or "Double round-robin tournament".

A match schedule is created on a new sheet.

Conditional formatting separates rounds with a line, it makes the table easier to read.

Round-robin tournament

Sub rr() Dim Lrow As Long Dim rng As Range, tmp() As Variant Dim ws As Worksheet Application.ScreenUpdating = False Lrow = Worksheets("Macro").Range("A" & Rows.Count).End(xlUp).Row Set rng = Worksheets("Macro").Range("A2:A" & Lrow) tmp = RoundRobin2(rng) 'Insert new sheet Set ws = Sheets.Add ws.Range("A1") = "Round" ws.Range("B1") = "Home" ws.Range("C1") = "Away" ws.Range("A2").Resize(UBound(tmp, 1), 3) = tmp ws.Range("A1").Resize(UBound(tmp, 1) + 1, 3).InsertIndent 1 Columns("A:C").EntireColumn.AutoFit ws.Range("A1:C1000").Select Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=$A1<>$A2" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Borders(xlBottom) .LineStyle = xlContinuous .TintAndShade = 0 .Weight = xlThin End With Selection.FormatConditions(1).StopIfTrue = False Application.ScreenUpdating = True End Sub

Double round-robin tournament

Sub droundrobin() Dim Lrow As Long Dim rng As Range, tmp() As Variant Dim ws As Worksheet Application.ScreenUpdating = False Lrow = Worksheets("Macro").Range("A" & Rows.Count).End(xlUp).Row Set rng = Worksheets("Macro").Range("A2:A" & Lrow) tmp = doubleroundrobin(rng) 'Insert new sheet Set ws = Sheets.Add ws.Range("A1") = "Round" ws.Range("B1") = "Home" ws.Range("C1") = "Away" ws.Range("A2").Resize(UBound(tmp, 1), 3) = tmp ws.Range("A1").Resize(UBound(tmp, 1) + 1, 3).InsertIndent 1 Columns("A:C").EntireColumn.AutoFit ws.Range("A1:C1000").Select Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=$A1<>$A2" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Borders(xlBottom) .LineStyle = xlContinuous .TintAndShade = 0 .Weight = xlThin End With Selection.FormatConditions(1).StopIfTrue = False Application.ScreenUpdating = True End Sub

This function moves values in an array randomly.

Function RandomizeArray1(Arr As Variant) Dim temp Dim i As Long, j As Long, k As Long Dim result As Variant For k = LBound(Arr, 1) To UBound(Arr, 1) result = result & Arr(k, 1) & " " Next k result = result & vbNewLine For i = LBound(Arr, 1) To UBound(Arr, 1) j = Application.WorksheetFunction.RandBetween(LBound(Arr, 1), UBound(Arr, 1)) temp = Arr(j, 1) Arr(j, 1) = Arr(i, 1) Arr(i, 1) = temp For k = LBound(Arr, 1) To UBound(Arr, 1) result = result & Arr(k, 1) & " " Next k result = "" Next i RandomizeArray1 = Arr End Function

If you want the vba code in your own workbook, do this.

- Press Alt-F11 to open visual basic editor
- Click Module on the Insert menu
- Copy and paste all custom functions above to the code module

- Exit visual basic editor (Alt+Q)
- Save your workbook as an *.xlsm file

Now you can use the custom functions. Type your teams in a column. Select a blank cell range, 3 columns wide and many rows, you can extend this later if not all rounds show up.

Type =doubleroundrobin(cell_ref_to_your_teams), press and hold CTRL + Shift. Press Enter. Release all keys.

]]>Is there a way where i can predict all possible outcomes in excel in the below example.

Total games are 13 (ABCDEFGHIJKLM). Possible outcomes are win(home team),draw or win(Away team) represented by 1,X or 2 respectively.Outcomes should be in the below formats

111111111111X

11111111111XX

2222222X22221

222222222222X

The following macro lets you enter text strings separated by a comma and the number of games.

Sub ListPermut() 'This macro creates a list of all permutations 'Get digital Help - http://www.get-digital-help.com/ 'Define variables Dim ws As Worksheet, Ans As String, ans1() As String, digits As Integer Dim num As Integer, p As Long, i As Long, t As Long Dim rng() As Long, c As Long, rng1() As String 'Insert a new sheet Set ws = Sheets.Add 'Ask for user input Ans = InputBox("Type strings separated with a comma:") digits = InputBox("How many strings?") 'Split text strings to an array ans1 = Split(Ans, ",") 'Count values in aray num = UBound(ans1) + 1 'Calculate number of permutations p = num ^ digits 'Redimension arrays ReDim rng(1 To digits) ReDim rng1(1 To digits) 'Save 1 to all values in first row of array For c = 1 To digits rng(c) = 1 Next c i = 0 'Don't show the result until finished Application.ScreenUpdating = False 'Repeat until all permutations have been created Do Until (i + t) = (p - 1) 'Use text strings instead of numbers For c = LBound(rng1) To UBound(rng1) rng1(c) = ans1(rng(c) - 1) Next c 'Transfer values from array to worksheet ws.Range("A1").Resize(, digits).Offset(i) = rng1 'Build next row of permutations For c = digits To 1 Step -1 If c = digits Then rng(c) = rng(c) + 1 ElseIf rng(c) = 0 Then rng(c) = rng(c - 1) End If If rng(c) = num + 1 Then rng(c) = 1 rng(c - 1) = rng(c - 1) + 1 End If Next c 'Count made permutations i = i + 1 'Insert a new sheet if rows exceed 999 999 If i = 1000000 Then Set ws = Sheets.Add t = t + 1000000 i = 0 End If Loop 'Use text strings instead of numbers For c = LBound(rng1) To UBound(rng1) rng1(c) = ans1(rng(c) - 1) Next c 'Transfer values from array to worksheet ws.Range("A1").Resize(, digits).Offset(i) = rng1 'Show output Application.ScreenUpdating = True End Sub

- Press Alt-F11 to open visual basic editor
- Click Module on the Insert menu
- Copy and paste code above to the code module

- Exit visual basic editor (Alt+Q)
- Save your workbook as a *.xlsm file

- Press Alt+F8 to open the macro dialog box
- Click ListPermut macro
- Click Run

Enter your text strings using a comma as a text delimiting character.

Click OK button.

Enter number of games.

Click OK button.

Excel processes the data for a while and then creates two sheets with a total of 1594323 permutations.

The picture shows 14 out of 1594323 permutations.

The most basic dialog box you probably have seen many times is the messagebox. In its most simple form it gives the user a message you specify and a OK button.

Sub Macro1() MsgBox "Hi, there!" End Sub

It is a great tool for quickly troubleshooting a subroutine or a custom function. The messagebox have more options than displaying text or variables, these are the arguments:

Sub Macro1() MsgBox "Prompt", vbOKOnly, "This is a title" End Sub

*Prompt* - Text shown in message box

*Buttons* - You can select of a variety of different buttons and icons. If you can't find the buttons you need, a user form is required.

*vbOKOnly - 0*

*vbOKCancel - 1*

*vbAbortRetryIgnore - 2*

*vbYesNoCancel - 3*

*vbYesNo - 4*

*vbRetryCancel - 5
vbCritical - 16
vbQuestion - 32
vbExclamation - 48
vbInformation - 64
vbDefaultButton1 - 0
vbDefaultButton2 - 256
vbDefaultButton3 - 512
vbDefaultButton4 - 768
*

*Title* - Text at the very top of the message box. (Optional)

*Helpfile - *Path to your helpfile. (Optional)

*Context - *A numerical expression. (Optional, required if you specify a helpfile)

There are six different button setups. The most basic message box shows a text string or a variable and an OK button.

Sub Macro1() MsgBox "Prompt", vbOKOnly End Sub

You don't even need to specify the vbOKOnly argument to show the above dialog box.

**vbOKCancel** argument displays OK and Cancel buttons.

Sub Macro1() MsgBox "Prompt", vbOKCancel End Sub

**vbAbortRetryIgnore** shows three buttons, abort, retry and ignore.

Sub Macro1() MsgBox "Prompt", vbAbortRetryIgnore End Sub

**vbYesNoCancel** also shows three button, Yes, No and Cancel

Sub Macro1() MsgBox "Prompt", vbYesNoCancel End Sub

**vbYesNo** diplays Yes and No buttons.

Sub Macro1() MsgBox "Prompt", vbYesNo End Sub

vbRetryCancel shows Retry and Cancel buttons.

Sub Macro1() MsgBox "Prompt", vbRetryCancel End Sub

**vbCritical** shows this icon on the message box.

Sub Macro1() MsgBox "Prompt", vbCritical End Sub

**vbQuestion** shows this query icon.

Sub Macro1() MsgBox "Prompt", vbQuestion End Sub

**vbExclamation** shows a warning icon.

Sub Macro1() MsgBox "Prompt", vbExclamation End Sub

**vbinformation** shows an information icon.

Sub Macro1() MsgBox "Prompt", vbInformation End Sub

If you look at the message box arguments in the beginning of this post, you will see a number next to each constant. Combining for example an OK and Cancel button with a query icon you simply add the numbers for those constants. OK and Cancel has value 1 and the query icon has value 32.

1 + 32 = 33

Sub Macro1() MsgBox "Prompt", 33 End Sub

You can combine constants intead of values, if you prefer that. See macro below, it produces the same result as the macro above.

Sub Macro1() MsgBox "Prompt", vbOKCancel + vbQuestion End Sub

You can change the default button for a message box, see the arguments in the beginning of this post. The following message box has the OK button as the default button, it has a dotted line around the text "OK".

You can change it to the second button by adding 256 to the second argument. 33 + 256 = 289

Sub Macro1() MsgBox "Prompt", 289 End Sub

If you prefer you can add the constants to the second argument, as well. This macro shows the same message box as above.

Sub Macro1() MsgBox "Prompt", vbOKCancel + vbQuestion + vbDefaultButton2 End Sub

The message box returns one of these values depending on which button was clicked on by the user.

vbOK - 1

vbCancel - 2

vbAbort - 3

vbRetry - 4

vbIgnore - 5

vbYes - 6

vbNo - 7

This message box allows you to click the OK button or the Close button. Both buttons result in the value 1 or vbOK.

Sub Macro1() Dim btt btt = MsgBox("You can click the OK button or the Close button", vbOKOnly) MsgBox btt End Sub

The following macro allows you to continue or stop a loop using a message box. If you click No the macro ends.

Sub Macro1() Dim a As Integer For a = 1 To 10 If MsgBox("a=" & a & " Continue?", vbYesNo) = vbNo Then Exit For Next a End Sub

Here is an example of how to use a msgbox with a helpfile.

Sub Macro1() MsgBox "Prompt", vbMsgBoxHelpButton, "This is a title", "c:\temp\helpfile.chm", 7 End Sub

The following macro shows you how to concatenate text and a variable.

Sub Macro1() Dim nm As String nm = "Jennifer" MsgBox "My name is " & nm End Sub

This macro shows you how to put text on two rows.

Sub Macro1() MsgBox "First row" & vbNewLine & "Second row" End Sub

You can also show data with a delimiting tab.

Sub Macro1() Dim a As Integer, result As String For a = 1 To 8 result = result & a & vbTab Next a MsgBox result End Sub

An input box asks the user for a value, you can specify the text and the title in the inputbox. You also have the option where to show the input box on screen and a default input value.

*prompt* - text in input box

*title* - Text at the very top of the input box

*default* - default value shown in the input box

*xpo*,*ypos* - specify where you want the input box on the screen from the upper-left corner.

*helpfile* - path to help file

*context* - A numerical value

This macro asks where you are from. Default value is "United Kingdom".

Sub Macro1() Dim Country Country = InputBox("Where are you from?", "Country", "United Kingdom") MsgBox Country End Sub

Note, if you click Cancel button the Input box returns nothing.

Excel input box is more versatile, it will do basic validation for you and the user can select a cell range on a worksheet. You have also the option to select one or multiple data types returned by the input box.

*prompt* - text in input box

*title* - Text at the very top of the input box

*default* - default value shown in the input box

*left, top* - specify where you want the input box from the upper-left corner of the screen.

*helpfile* - path to help file

*HelpContextID* - A numerical value

*Type* - A number representing the data type returned

0 - Formula

1 - Number

2 - Text

4 - Logical value, True or False

8 - A cell reference

16 - Error value

64 - An array of values

Sub Macro1() Dim cd cd = Application.InputBox("Enter birth year", , , , , , , 1) MsgBox "Your birth year is " & cd End Sub

Excel provides basic data validation, if you type a text string excel gives you this warning message.

If you click "Cancel" button excel returns "False".

Data type 8 (Cell reference) lets the user select a cell range.

Sub Macro1() Dim rngAs Range Set rng = Application.InputBox("Select a range: ", , , , , , , 8) MsgBox "You selected " & rng.Address End Sub

If the user enters something else than a cell reference excel gives this message until a valid cell reference is entered:

Clicking on "Cancel" button makes excel error out:

If you combine data types by adding their corresponding value, like this 1+2 = 3 the user is allowed to enter both numbers and text.

Sub Macro1() Dim cd cd = Application.InputBox("You can enter both text an numbers: ", , , , , , , 3) MsgBox "You entered " & cd End Sub

Data in this table is made up and random.

The data form is a smart dialog box, it analyzes your table and customizes the dialog box using table headers.

Make sure you have a cell selected in the table you want to work with before running this macro:

Sub Macro1() ActiveSheet.ShowDataForm End Sub

FileDialog property lets you prompt the user for a directory or open/save/select a file

fileDialogType - Choose between 4 constants, see below.

msoFileDialogFilePicker - Select a file

msoFileDialogFolderPicker - Select a folder

msoFileDialogOpen - Open a file

msoFileDialogSaveAs - Save a file

Allows the user to select a file. The following macro prompts the user for a file o multiple files and then a message box returns the path and file name for each file.

Sub Macro1() Dim i As Integer With Application.FileDialog(msoFileDialogFilePicker) .Show For i = 1 To .SelectedItems.Count MsgBox .SelectedItems(i) Next i End With End Sub

The following macro lets the user pick a folder. A message box displays the path and folder name.

Sub Macro1() Dim i As Integer With Application.FileDialog(msoFileDialogFolderPicker) .Show MsgBox .SelectedItems(1) End With End Sub

The macro below asks the user for a file to open. A message box displays the path and file name. Note, it doesn't open the file.

Sub Macro1() Dim i As Integer With Application.FileDialog(msoFileDialogOpen) .Show MsgBox .SelectedItems(1) End With End Sub

This macro lets the user pick a folder and a save name. A message box displays the path and file name. It doesn't save the file

Sub Macro1() Dim i As Integer With Application.FileDialog(msoFileDialogOpen) .Show MsgBox .SelectedItems(1) End With End Sub

Filefilter - Filter criteria (Optional)

FilterIndex - Index number of default filter (Optional)

Title - title of dialog box (Optional)

Multiselect - Enables the user to select multiple filenames (Optional)

The following macro asks for a file to open, filters used are *.xlsx and *.xlsm. The second filter is the default value. Keep in mind, the macro doesn't open the file it just returns a file name and path.

Sub Macro1() Dim txt txt = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx, Excel macro files (*.xlsm),*.xlsm", 2) MsgBox txt End Sub

If the user clicks "Cancel" False is returned.

Filefilter - Filter criteria (Optional)

FilterIndex - Index number of default filter (Optional)

Title - title of dialog box (Optional)

Sub Macro1() Dim txt txt = Application.GetSaveAsFilename("Excel Files (*.xlsx), *.xlsx, Excel macro files (*.xlsm),*.xlsm", 2) MsgBox txt End Sub

This macro does not save the file, it only returns the selected path and name.

]]>You can read about the difference between combinations and permutations here: Return all combinations but in short, the order is important for permutations and not important for combinations.

This number 303 030 000 is equal to 9 if you sum every digit, 3+0+3+0+3+0+0+0+0 = 9. 92 is above 9, 9+2 = 11 and is not a number we are looking for.

This user defined function sums all digits in a number.

Function SumChr(nmbr As Long) Dim sm As Long For i = 1 To Len(CStr(nmbr)) sm = sm + Val(Mid(nmbr, i, 1)) Next i SumChr = sm End Function

Here is a picture of the SumChr function in use.

It is easy to iterate through every number between 0 and for example 10 000 000 and check if the digit sum is smaller or equal to 9. The following udf does that:

Function CalcVal(k As Double) Dim i As Long, j() As Double, a As Double ReDim j(0 To 60000, 1) a = Timer l = 0 For i = 0 To k m = SumChr(i) If m = 9 Then j(l, 0) = i j(l, 1) = m l = l + 1 End If Next i j(0, 1) = Timer - a CalcVal = j() End Function

The picture below shows all numbers between 0 and 20 where the digit sum is smaller or equal to 9, the CalcVal function above made this list. Number 19 is missing, 1+9 = 10. 10 is bigger than 9. Column B contains the digit sum, except cell B1. It has the time it took to calculate the list. In this case it took almost no time at all and excel rounded it to 0 (zero).

The problem is if you try to do the same with a really large range of numbers, it will take a very long time to calculate for a desktop pc. This udf shortens that time considerably.

Function CalcVal1(k As Single) Dim i As Single, j() As Double, a As Double Dim l As Single, m As Single a = Timer ReDim j(0 To 2000000, 1) i = -1: m = 0 Do Until k <= i If SumChr(i) = 9 Then p = Len(CStr(i)) For l = Len(CStr(i)) To 1 Step -1 If Mid(i, l, 1) <> 0 And Mid(i, l, 1) <> 9 Then i = Val(ReplaceChrInStr(i, l, 0)) i = Val(ReplaceChrInStr(i, l - 1, Mid(i, l - 1, 1) + 1)) Exit For ElseIf Mid(i, l, 1) = 9 Then i = i + Application.WorksheetFunction.Power(10, Len(CStr(i)) - 1) Exit For End If Next l Else i = i + 1 End If If i <= k Then j(m, 0) = i Else j(m, 0) = "" End If j(m, 1) = SumChr(i) m = m + 1 Loop j(0, 1) = Timer - a CalcVal1 = j End Function

The UDF basically examines each digit in a number and if the sum is 9 these things happens:

- If digit is not equal to 9 and zero, make that digit a 0 and add 1 to the next digit.
- If digit is equal to 9, add 1,10, 100... depending on the position (n) the digit has in the number. Example, digit 9 in number 90 is the second digit counting from right to left, n=2. 10^(2-1) is 10. 90+10 = 100

If the digit sum is not equal to 9 the udf adds 1 to the current number and the loop continues until the entire range has been created.

Now lets compare the run times of the two udfs CalcVal and CalcVal1.

For smaller ranges like 0 - 9000 CalcVal is faster, somewhere around perhaps 5000 CalcVal1 seems to take the lead.

I am using an old laptop with a dual core intel i3 cpu, I am getting 29% utilization. I don't know why, it seems that only one core is utilized by excel. In any case, the numbers indicate that the CalcVal1 function is much faster.

]]>