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

Showing posts with label **macros**. Show all posts

Showing posts with label **macros**. Show all posts

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

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

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

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**

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:

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.

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:

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.

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

- 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

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:

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

__Random Paths__

=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.

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).

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)

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**

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

'*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

AnyChanges = False

x = TempVar: TempVar = "" '

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...

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:

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 SubRepeat:

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)"

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 SubDim 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

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.

Subscribe to:
Posts (Atom)