Excel Interface: Hide or Restore

Normally, Excel application displays user interface (ribbon standard) like this (top and bottom parts):

Unique Macro Buttons - Unlimited

If you use macros (VBA code) in Excel you probably use macro buttons as well. There are many ways to create them, but the one I like the most is to utilize just the Excel cells. Yes, nothing else but the cells. Cells are 'pictures'. Obviously, if you'd like to "decorate" them in any way, you could; and at least you'd probably like to mark them somehow in order to recognize that they hold your macro code.

So, you'd start with selecting a cell and entering some (centered) text into it, e.g. 'Run abc...'. Next, to create the button, you'd:

• copy the cell (using CTRL+C shortcut) and paste it to the same cell (or another - it's your choice) as a Picture (using ALT+H+V+U shortcut)
• right-click in the cell and select Size & Properties > Properties and select Move & size with cells option (this way the 'picture' will always fit and stay in the same cell)
• right-click again, select Assign Macro... from the menu and select your macro from the list you'd see in Assign Macro dialog

The cell is now your macro button. Click it to run your assigned macro.

If you'd like to make the button more distinct (visible) you'd add some shape or photo or icon and/or format the cell at your will (prior to pasting it (!) as a Picture). Here is a couple of ideas, if you want to make the button unique:

Creating Pixel Art - Iterations

You can use Excel to create some work of art. Over 32000 iterations can be utilized, and this allows to produce lots of pixels in your worksheet and, practically, create unlimited number of 2D 'pictures' and 3D 'sculptures'. All you need is to use the two macros presented at the end of this post (one for drawing and the other for erasing) and some creativity, obviously.

To give you an idea what kind of 'art' I'm talking about, here are just couple of examples:

 

 

Before starting your creative work you need to determine name for your picture. Go to Formulas > Define Name in your workbook and enter TRI in the Name: field and =Sheet1!$B$2:$ZZ$601 in Refers to: field.

Next, insert and format two Buttons (Form Controls) similar to what you see here:

Goto to Developer > Insert > Button, add the text (Draw..., Erase...) and assign the two macros to them. You'll use the buttons to create and erase the pictures.

Now you can copy the macros listed below to one of the modules inserted in your workbook (VBAProject). At this point you're ready to start experimenting with the pixel art. There are several parameters (variables) plus functions, formulas, equations, colors etc. that can be changed and manipulated at will.

Here are the macros:

Option Explicit
Sub Sculpture()
'Produces graphics: from random mist to well defined pixel art
'Use provided parameters and translations to define "sculptures"
'Takes several seconds to produce some pixel art
Dim cP(3) As Long
Dim wid As Double
Dim myPts As Single
Dim myRange As Range
Dim cx As Double, cy As Double, rC As Double, iC As Double
Dim xUL As Double, xLL As Double, yUL As Double, yLL As Double
Dim y As Double, x As Double, c As Double, d As Double
Dim intW As Integer, intH As Integer, i As Integer, j As Integer
Dim a As Single, b As Single, sPercent As Single, co As Single
'Color palette; change as needed
cP(0) = 65280       'green
cP(1) = 65535       'yellow
cP(2) = 13382400    'blue
cP(3) = 255         'red
On Error GoTo TheEnd
'Set your canvas range for square cells; here set to B2:ZZ601
Set myRange = Application.InputBox("Select a range in which to create square cells", ,  _"$B$2:$ZZ$601", Type:=8)
On Error Resume Next
If myRange.Cells.Count = 0 Then Exit Sub
GetWidth:       'Set the width of cells (0.08 is my screen pixel size)
wid = Val(InputBox("Input Column Width:", , "0.08"))
If wid < 0.08 Then
    MsgBox "Invalid column width value"
    GoTo GetWidth
End If
Application.ScreenUpdating = False
myRange.EntireColumn.ColumnWidth = wid
myPts = myRange(1).Width        'Set row height
myRange.EntireRow.RowHeight = myPts
xLL = -1.02: xUL = 3.02: yLL = -1.02: yUL = 2.59
intW = myRange.Columns.Count: intH = myRange.Rows.Count
Application.Goto reference:="TRI"   'TRI is the named range (=Sheet1!$B$2:$ZZ$601")
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .Color = 0   'Background color; set to black
End With
Range("A1").Select
x = 0: y = 0
cx = 1: cy = 0.5
a = Rnd() * (-10 - 10) + 10: b = Rnd() * (-10 - 10) + 10  'Random real numbers between -10 & 10
For j = 1 To 4      'Iterate by colors
    Select Case j
        Case 1
            co = cP(0)
        Case 2
            co = cP(1)
        Case 3
            co = cP(2)
        Case Else
            co = cP(3)
    End Select
    For i = 1 To 30000  'Number of iterations with each of the colors
        x = cx: y = cy
        c = Sin(a * x): d = Cos(b * y ^ 2)  'Use any other formulas to get desirable results
        cx = d + c * c + 0.6: cy = Sin(2 * a * x) - Sin(c) * d + 0.8    'As above
        iC = Int(intW * (cx - xLL) / (xUL - xLL)): rC = Int(intH * (cy - yLL) / (yUL - yLL))
        myRange.Cells(1 + rC, 1 + iC).Interior.Color = co
        If iC < 2 Then iC = 2: If iC > intW Then iC = intW
        If rC < 2 Then rC = 2: If rC > intH Then rC = intH
    Next i
Next j
Range("Sheet1!B1").Select
myRange.Cells(1, 1).Offset(-1, 0) = "Basic parameters used: a=" & Format(a, "#0.0;-#0.0") & ", b=" & _Format(b, "#0.0;-#0.0")
Application.ScreenUpdating = True
myRange.Cells(1, 1).Offset(-1, -1).Select
TheEnd:
Set myRange = Nothing
If Application.ScreenUpdating = False Then Application.ScreenUpdating = True
End Sub
 

Sub EraseSculpt()
'Clear the graphic and restore cell size
Dim TRI As Name
Application.ScreenUpdating = False
    Application.Goto reference:="TRI"
    Selection.Clear
    With Selection
        .ColumnWidth = 8.43
        .RowHeight = 12.75
    End With
    Range("B1").Select
    Selection.ClearContents
    Range("A2").Select
Application.ScreenUpdating = True
End Sub
 

How to create Activity Tracker / Timer

If you'd like to keep in Excel the record of your common daily tasks, in terms of disciplined use of your valuable time, then the solution I'm providing here can be helpful. It makes easy recording of duration of any routine daily activities and provides basis for further analysis of any kind.

This is how it looks like in an exemplary edition:

How to create a 'slide show' using a single formula and a chart

If you want to make use of some math formulas for practical applications or just to show off your Excel creativity, you can utilize kind of slide show: = refreshable charts based on your brilliant formula.

Follow these steps:

• Open a new workbook. Enter any two numbers into your worksheet (Sheet1), e.g. 1 in cell A2 and 2 in B2.
• Start with creating a simple XY scatter chart based on your entries. This chart is named as "Chart 1".
• Delete the two numbers you've just entered. You don't need them.
• Expand the width of column A to e.g. 200, move there the chart and resize it to the size of your choice.
• In cell D1, type the formula you want to chart, in the format using explicitly normal math signs and functions, e.g. x^2+5*sqrt(x)-3 .
• Enter the low and high limits (of your choice) for the Left value and the Right value of x axis, then also the Low and High limits for the number of Points you want to be plotted, as shown in the example below (cells D3:E5).
• In cells F3:F5, enter RANDBETWEEN formulas as shown in the example, cells F3:F5.

Outliers in normally distributed datasets

I've recently touched the subject of statistical analysis of data using Excel functions. In this post I dive deeper into Excel statistical tools. It's about outliers in data sets, about numbers that distort the state of reality and can lead to unsound findings and conclusions regarding specific areas of knowledge.

There are no strict statistical rules for indisputable ways of identifying outliers; we are dealing with probabilities. Nonetheless, there are guidelines and tests we can utilize to find outlying values, and they can significantly improve our intuition, formally.

Because of the importance of detecting outliers I've prepared Excel workbook providing practical tools (tests) for identifying such deviating/departing values within any set of numerical data. The workbook includes basic guidelines for using some specific statistical tests; I'm showing here its fragment:

Presentations in Excel

If most of your work, you do for presentations, comes from Excel, there is no reason to use the PowerPoint instead of Excel itself for preparing your demonstration.

In fact, all your charts, tables, forms, textual info, background graphics, and even sounds, can be quite easily presented and put in order in Excel worksheets.  All the hassle with extra work of copying and pasting into PowerPoint could not be necessary.

Let's say, you've carried out your data analysis and prepared workbook with 30 perfect  worksheets ('slides') for your quarterly presentation. How would you proceed to get ready for reporting your work? Switching to PowerPoint? Not necessarily.

If you'd decide to stay with Excel, the following steps could probably be more efficient way to go. 

First, put all your presentable worksheets in consecutive order in which they'll be presented.

Add a blank worksheet dedicated to a title page. Excel has all the tools needed to create an attractive design. Such a worksheet could show just the subject of your presentation or might be a bit more elaborated, as e.g. in this figure:

Similarly, you can add another worksheet for displaying "The end" page, if appropriate.

Colorful randomized worksheet creations

Using some Excel functions and conditional formatting you can create unusual graphics, backgrounds, images etc. Here are some of my creations.

Labyrinth

I followed these steps to create this example:

• selected the sheet and set column width to 2
  
• entered in cell B2 this formula: =IF(SUM(A1:C1)=INT(RAND()+0.5),1,"")
• copied the formula to B2:BC30 range
• used Conditional Formatting to display the icons, namely: selected the range and set formatting rule to show icon when cell value is >=1, and no icon when cell value is <1 and >=0
• filled the range with green background color
  

Sierpiński Triangle

 

This triangle was created as described here:

• selected the sheet and set column width to 2
  
• entered in cell B2 this formula: =IF(SUM(A1:C1)=1,1,"")
• copied the formula to B2:BR37 range
• entered "1" in cell AJ3
  
• used Conditional Formatting to display the icons, namely: selected the range and set two formatting rules:

1. Format based on Icon Sets style when cell value is >=1, and
2. Format only cells containing cell value ="" to selected Color and Pattern
   

Random Paths

This random pattern has been created, after setting column width to 2, with the following formula:

=IF(SUM(A1:C1)>0,SIN(RAND()*45),COS(RAND()*45))

entered in cell B2 and copied to B2:BC30 range. In Conditional Formatting I used formatting rule with Icon Set, when cell values is>=75 percent,<75 and>=50 percent, and <50 and >=25 percent.

Mosaic

To create a similar mosaic of colors in certain range of quadratic cells, set the column width to 2 and then use the following macro code. You need to copy and paste the code into open VBE space (press ALT+F11 to get there).

Sub RandomColors()
Dim rng As Range
Dim WorkRng As Range
Dim xRed As Byte
Dim xGreen As Byte
Dim xBlue As Byte
On Error Resume Next
xTitleId = "MyColors"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
For Each rng In WorkRng

xRed = Application.WorksheetFunction.RandBetween(0, 255)
xGreen = Application.WorksheetFunction.RandBetween(0, 255)
xBlue = Application.WorksheetFunction.RandBetween(0, 255)
rng.Pattern = xlSolid
rng.PatternColorIndex = xlAutomatic
rng.Interior.Color = VBA.RGB(xRed, xGreen, xBule)

Next
End Sub

SUDOKU Solver and Creator

If you are Sudoku solver you probably spent hours and hours trying to solve the puzzles. I'd like to show here that in Excel, with help of VBA macros, you can do it usually in seconds.

Create your own private Sudoku solver tool, which will not only solve the puzzle but also create your own, at different levels of difficulty. I'll guide you through all the steps.

In the first step, you'll need to design your worksheet structure/view. Start with Sudoku 9 x 9 cells square. Use any colors you like to create a pleasant display of the matrix. I've used RowHeight of 33 and ColumnWidth of 6 to make cells look like squares.

Here is my design shown in two stages: with blank fields (before creating a puzzle) and with filled fields (after solving a puzzle).

After formatting of the layout as presented in the example above, comes the second step - filling designated cells with formulas. Enter them as follows:

• Make sure that the range of cells P1:X9 is left blank. 
• Hide Columns L:AJ and AN:DP.

Step three. Now you need to insert three command buttons: Create, Solve, and Clear, as you see in the example above.

In Developer Menu Controls turn on the Design Mode and click on Insert to insert Command Button from ActiveX Controls. Size the button as needed.

Right-click on the button and select Properties. Change Caption Name to "Create". Right-click again on the button and select View Code. In the Sheet1 code page enter the following code:

Private Sub CommandButton1_Click()
'CommandButton "Create"
Range("sudoku").Font.Color = vbBlack
RrLogic = 1
MainCod
End Sub

Return to your worksheet and create next two buttons the same way, but name them "Solve" and "Clear".

For "Solve" button enter the following code:

Private Sub CommandButton2_Click()
'CommandButton "Solve"
'Dim CheckArray(9)
If Cells(1, 38) = 0 Then End ' Checks if the empty cells are 0(solved sudoku)
Range("sudoku").Font.Color = vbBlack
For x = 1 To 9 'checks if there are same numbers in row,column,box
  For y = 1 To 9
    rX = "a" & x & ":" & "i" & x ' Finds the coords of the range(row,column,box)
    rY = Chr(y + 64) & "1" & ":" & Chr(y + 64) & "9"
    xK = 1 + Int((x - 1) / 3) * 3
    yK = 1 + Int((y - 1) / 3) * 3
    rK = Chr(yK + 64) & xK & ":" & Chr(yK + 66) & xK + 2
    r = rX & "," & rY & "," & rK
    Set MyRange = Range(r)
    If Cells(x, y) = "" Then GoTo nextxy
    temp = Cells(x, y)
    Cells(x, y) = ""
    For Each c In MyRange.Cells
        If c.Value = temp Then
            Cells(x, y) = temp
            c.Font.Color = vbRed
            Cells(x, y).Font.Color = vbRed
            Message = MsgBox("Exits Sudoku", vbOKOnly)
            End
        End If
    Next
Cells(x, y) = temp
nextxy:
 Next y, x
 For x = 1 To 9 'Input data in an array
  For y = 1 To 9
      InputData(x, y) = Cells(x, y)
Next y, x
RrLogic = 2 ' If RrLogic =1 then Create Sudoku or If RrLogic =2 then Solve Sudoku
MainCod
End Sub 

For "Clear" button enter this code:

Private Sub CommandButton3_Click()
'CommandButton "Clear"
Range("sudoku").Font.Color = vbBlack
For x = 1 To 9
  For y = 1 To 9
   Cells(x, y) = ""
Next y, x
End Sub

In step four, enter shortcut ALT+F11 to open VBE page and click on the View in menu to select Project Explorer. If there is no Module available within your VBA Project, then insert one by clicking on the Insert in the menu. Double-click on the Module and and paste there the following Sub procedures:

Public InputData(9, 9), SpecialAr(), XCoords(), YCoords(), RrCount, RrLogic, CurNum As Integer
Public IsZero, AnyChanges As Boolean
Public x, y, MidNum, TempVar
Public MyRange As Range
Public TheSame As String

Public Sub MainCod()
Randomize Timer
wrongRep = 0: Xronos = Timer
1 IsZero = False
If RrLogic = 1 Then CreateSudoku Else SolveSudoku
wrongRep = wrongRep + 1     'Count of tries to solve sudoku
Do
CheckArea:
IsZero = False      'Becomes True when "123456789" is zero
If Cells(2, 38) = 1 Then GoTo 3 'Check if unique num in 2nd string array (in row, col or box)
ReDim SpecialAr(9), XCoords(4), YCoords(4)
AnyChanges = False  'True if any changes made after any check
For x = 1 To 9  'Row check
    For y = 1 To 9
    For k = 1 To Len(Cells(x, y + 15))
    If Cells(x, y + 15) = "0000000000" Then Exit For
    MidNum = Mid(Cells(x, y + 15), k, 1)
    SpecialAr(MidNum) = SpecialAr(MidNum) + 1     'Counts occurrence of a number in row
    Next k
Next y
    For l = 1 To 9
        If SpecialAr(l) = 1 Then
            For y = 1 To 9      'Find cell with the unique number
                For k = 1 To Len(Cells(x, y + 15))     'Loop every char in the string
                    MidNum = Mid(Cells(x, y + 15), k, 1)
                    If Val(MidNum) = l Then
                        Cells(x, y) = l     'The unique number in the 1st table
                        Cells(x, y + 15) = "0000000000"     'Set the string in the array for every completed cell in the 1st table
                        CurNum = Cells(x, y)     'Current cell investigated
                        RepairStr   'Calls the sub fixing the string table after cell is completed in 1st table
                        If IsZero = True Then GoTo 1 'Go back to the beginning if cannot go any further
                        GoTo CheckArea      'Make all the check if any change has been made
                    End If
            Next k, y
            Else
        End If
    Next l
ReDim SpecialAr(9)
Next x
'Column check
For y = 1 To 9     'The same as above with exchanging the x and y coordinates
  For x = 1 To 9
    For k = 1 To Len(Cells(x, y + 15))
      If Cells(x, y + 15) = "0000000000" Then Exit For
      MidNum = Mid(Cells(x, y + 15), k, 1)
      SpecialAr(MidNum) = SpecialAr(MidNum) + 1
 Next k
 Next x
  For l = 1 To 9
     If SpecialAr(l) = 1 Then
       For x = 1 To 9
        For k = 1 To Len(Cells(x, y + 15))
         MidNum = Mid(Cells(x, y + 15), k, 1)
         If Val(MidNum) = l Then
         Cells(x, y) = l: Cells(x, y + 15) = "0000000000"
         CurNum = Cells(x, y)
         RepairStr
         If IsZero = True Then GoTo 1
         GoTo CheckArea
         End If
        Next k, x
        Else
        End If
  Next l
  ReDim SpecialAr(9)
Next y
x = 0: y = 0
'Box check
For i = 1 To 6 Step 3     'The same as above but using the x and y coordinates of the box
  For j = 1 To 6 Step 3
     For n = 0 To 2
        For g = 0 To 2
            x = i + n: y = j + g
            For k = 1 To Len(Cells(x, y + 15))
                If Cells(x, y + 15) = "0000000000" Then Exit For
                MidNum = Mid(Cells(x, y + 15), k, 1)
                SpecialAr(MidNum) = SpecialAr(MidNum) + 1
            Next k
        Next g, n
  For l = 1 To 9
     If SpecialAr(l) = 1 Then
     For n = 0 To 2
        For g = 0 To 2
            x = i + n: y = j + g
        For k = 1 To Len(Cells(x, y + 15))
         MidNum = Mid(Cells(x, y + 15), k, 1)
         If Val(MidNum) = l Then
         Cells(x, y) = l: Cells(x, y + 15) = "0000000000"
         CurNum = Cells(x, y)
         RepairStr
         If IsZero = True Then GoTo 1
         GoTo CheckArea
         End If
        Next k
        Next g, n
        Else
        End If
 Next l
ReDim SpecialAr(9)Next j, i
'Check if there is a couple a triad or tetrad in the same row, column or box
If RrLogic = 1 Then GoTo 3
For x = 1 To 9 'row check
   For y = 1 To 8
      For k = y + 1 To 9
        If Cells(x, y + 15) = Cells(x, k + 15) And Len(Cells(x, y + 15)) < 5 Then
            YCoords(1) = y: TheSame = Cells(x, y + 15)
            For i = 2 To 4     'Give the Y coords of the same cells to the YCoords array
            If YCoords(i) = 0 Then YCoords(i) = k: Exit For
            Next i
        Else
        End If
      Next k
'If there are same cells, call the CheckSameY sub & keep the current row in the TempVar variable
If YCoords(1) <> 0 Then TempVar = x:  CheckSameY: Exit For
Next y
If IsZero = True Then GoTo 1
If AnyChanges = True Then GoTo CheckArea
Next x
IsZero = False
For y = 1 To 9  'Column check
For x = 1 To 8
For k = x + 1 To 9
If Cells(x, y + 15) = Cells(k, y + 15) And Len(Cells(x, y + 15)) < 5 Then
XCoords(1) = x: TheSame = Cells(x, y + 15)
For i = 2 To 4      'Give the Y coords of the sam cells to the YCoords array
If XCoords(i) = 0 Then XCoords(i) = k: Exit For
Next i
Else
End If
Next k
'If there are same cells then call the CheckSameY sub & keep the current row in the TempVar variable
If XCoords(1) <> 0 Then TempVar = y:  RemRepeats: Exit For
Next x
If IsZero = True Then GoTo 1
If AnyChanges = True Then GoTo CheckArea
Next y
'Take the returned value of match function which finds the string with the minimum legth
3 synt = Cells(3, 38)
'Convert the coordinates of the 1x81 array to the 9x9 array
x = Int((synt - 1) / 9) + 1
y = synt - (Int((synt - 1) / 9) * 9)
PithNum = Cells(x, y + 15)     'Give to a var the string with possible number for the cell
'Return a random number from 1 to the length of the string
RndNum = Int(Rnd * Len(Cells(x, y + 15))) + 1
'Give to a var the corresponding number
CurNum = Mid(PithNum, RndNum, 1)
Cells(x, y) = CurNum
Cells(x, y + 15) = "0000000000"
RepairStr
If IsZero = True Then GoTo 1
Loop Until Cells(1, 38) = 0
Cells(4, 38) = wrongRep
Cells(5, 38) = Timer - Xronos
If RrLogic = 1 Then DelCells
End Sub

Public Sub CreateSudoku()
'Prepare the tables to start creating a new sudoku
For x = 1 To 9
For y = 1 To 9
Cells(x, y + 15) = "123456789"
Cells(x, y) = ""
Next y, x
End Sub

Public Sub SolveSudoku()
'Solve a sudoku given by the user or created from the program
For x = 1 To 9     'Gives all the combinations to the string table
  For y = 1 To 9
    Cells(x, y + 15) = "123456789"
Next y, x
For x = 1 To 9  'Insert all the given data from the array into the 1st table
  For y = 1 To 9
   If InputData(x, y) = 0 Then Cells(x, y) = "": GoTo 2
   Cells(x, y) = InputData(x, y)
   Cells(x, y).Font.Color = vbRed     'Cells with data become red
  CurNum = Cells(x, y)     'For any given num fix the corresponding string
  Cells(x, y + 15) = "0000000000"
  RepairStr
         If IsZero = True Then Message = MsgBox("Not Possible", vbOKOnly): End
2 Next y, x
End Sub

Public Sub RepairStr()
 rX = "p" & x & ":" & "x" & x     'Make the range in 2nd table, for every cell of 1st table, which contains row, column and box
    rY = Chr(y + 79) & "1" & ":" & Chr(y + 79) & "9"
    xK = 1 + Int((x - 1) / 3) * 3
    yK = 1 + Int((y - 1) / 3) * 3
    rK = Chr(yK + 79) & xK & ":" & Chr(yK + 81) & xK + 2
    r = rX & "," & rY & "," & rK
    Set MyRange = Range(r)
    For Each c In MyRange.Cells 'Subtract the current number from any string of the range
        For j = 1 To Len(c.Value)
           If Mid(c.Value, j, 1) <> CurNum Then tempXY$ = tempXY$ + Mid(c.Value, j, 1)
        Next
        If tempXY$ = "" Then IsZero = True 'Check if the string with possible num is nothing that means that the sudoku cannot be solved
        c.Value = tempXY$
        tempXY$ = ""
     Next
End Sub

Public Sub CheckSameY() 

'Subtract diads, triads and tetrads from the string in the same row
AnyChanges = False
x = TempVar: TempVar = ""     'Variable containing the current x coordinate
metritis = 0
If YCoords(Len(TheSame)) = 0 Then ReDim YCoords(4): Exit Sub

 For k = 1 To 9
 If Cells(x, k + 15) = "0000000000" Then metritis = metritis + 1
 Next k
 'Check if there are no more empty cells in the 1st table except the diads, triads or tetrads
 If Len(TheSame) + metritis = 9 Then ReDim YCoords(4): Exit Sub
For y = 1 To 9
    For i = 1 To Len(TheSame)
        If y = YCoords(i) Then GoTo 1     'Prevent the program from subtracting the numbers from the cells which contains the diads, triads or tetrads
    Next i
    For i = 1 To Len(TheSame)
        For k = 1 To Len(Cells(x, y + 15))
          MidNum = Mid(Cells(x, y + 15), k, 1)
          If MidNum <> Mid(TheSame, i, 1) Then TempVar = TempVar + MidNum
          If MidNum = Mid(TheSame, i, 1) Then AnyChanges = True
        Next k
     If TempVar = "" Then IsZero = True
     Cells(x, y + 15) = TempVar
     TempVar = ""
    Next i
1 Next y
ReDim YCoords(4)
End Sub
Public Sub RemRepeats() 'Subtract diads, triads and tetrads from the string in the same row
AnyChanges = False
 y = TempVar: TempVar = ""     'Variable containing the current y coordinate
 metritis = 0
 If XCoords(Len(TheSame)) = 0 Then ReDim XCoords(4): Exit Sub
 For k = 1 To 9
 If Cells(k, y + 15) = "0000000000" Then metritis = metritis + 1
 Next k
 'Check if there are no more empty cells in the s1 tables except the diads, triads or tetrads
 If Len(TheSame) + metritis = 9 Then ReDim XCoords(4): Exit Sub
For x = 1 To 9
'Prevent the program from subtracting the numbers from the cells which contains the diads, triads or tetrads
    For i = 1 To Len(TheSame)
        If x = XCoords(i) Then GoTo 1
    Next i
    For i = 1 To Len(TheSame)
        For k = 1 To Len(Cells(x, y + 15))
          MidNum = Mid(Cells(x, y + 15), k, 1)
          If MidNum <> Mid(TheSame, i, 1) Then TempVar = TempVar + MidNum
          If MidNum = Mid(TheSame, i, 1) Then AnyChanges = True
        Next k
     If TempVar = "" Then IsZero = True
     Cells(x, y + 15) = TempVar
     TempVar = ""
    Next i
1 Next x
ReDim XCoords(4)
End Sub

Public Sub DelCells()
'Delete cells randomly(get ready to play)
RrCount = 0
10 Do
x = Int((Rnd * 9) + 1)
y = Int((Rnd * 9) + 1)
'Stop
If Cells(x, y) <> "" Then
    Cells(x, y) = ""
Else
    GoTo 10
End If
RrCount = RrCount + 1
Loop Until RrCount = Cells(6, 38)
End Sub

Go back to your worksheet. Turn off the Design Mode and check if everything was entered correctly and works as intended. Finish any formatting and save your workbook as Macro-Enabled one.

Happy Sudoku-ing...

 

Unhide SOME of hidden Rows / Columns

It's quite easy to unhide a whole range of hidden columns or rows in a worksheet. But what if you want to unhide just one specific row or column, or a couple of them only.

Let's say, you've hidden e.g. columns from M to W, and rows from 30 to 40. Now you need to unhide columns S-T and rows 35-38 only. In such a situation probably the best way is a macro way. The following two macros can be very helpful:

Sub UnhideSomeRows()
'Unhide one or more of the hidden rows

Dim sRows As String
Repeat:
    sRows = Application.InputBox("Enter row number(s) to unhide", "Unhide row(s)", "e.g. 12 or 20:25")
    If sRows = "" Then Exit Sub
    On Error Resume Next
    If Err.Number <> 0 Then
        On Error GoTo 0
        Err.Clear
        MsgBox "Please input valid row(s)."
        GoTo Repeat
    End If
    Rows(sRows).EntireRow.Hidden = False
    MsgBox "Row(s) " & sRows & " is/are visible now", vbOKOnly, "Unhide specific Row(s)"

End Sub

Sub UnhideSomeColumns()

'Unhide one or more of the hidden columns

Dim sCols As String
Dim rRng As Range
Repeat:
    sCols = InputBox("Enter column(s) to unhide", "Unhide some of hidden Column(s)", "e.g. H or K:M")
    If sCols = "" Then Exit Sub
    On Error Resume Next
    Set rRng = ActiveSheet.Columns(sCols)
    If Err.Number <> 0 Then
        On Error GoTo 0
        Err.Clear
        MsgBox "Please input valid column(s)"
        GoTo Repeat
    End If
    rRng.EntireColumn.Hidden = False
    MsgBox "Column(s) " & UCase(sCols) & " is/are visible now", vbOKOnly, "Unhide specified Columns"
    Set rRng = Nothing
    On Error GoTo 0

End Sub

I've assigned them to separate Control buttons and gave them names "Unhide Rows" and "Unhide Columns". If you need help to do that, see this link: How to add a button and assign a macro .

I've then combined the two buttons into one, by moving and grouping them together as illustrated in this figure:

 

To unhide any columns or rows in my worksheet I just click on corresponding line of text on the button.