Excel shortcut and function keys

The following lists contain CTRL combination shortcut keys, function keys, and some other common shortcut keys, along with descriptions of their functionality.

 Tip   To keep this reference available when you work, you may want to print this topic. To print this topic, press CTRL+P.
 Note   If an action that you use often does not have a shortcut key, you can record a macro to create one.

In this article

• CTRL combination shortcut keys
• Function keys
• Other useful shortcut keys

CTRL combination shortcut keys

Key	Description
CTRL+PgUp	Switches between worksheet tabs, from left-to-right.
CTRL+PgDn	Switches between worksheet tabs, from right-to-left.
CTRL+SHIFT+(	Unhides any hidden rows within the selection.
CTRL+SHIFT+)	Unhides any hidden columns within the selection.
CTRL+SHIFT+&	Applies the outline border to the selected cells.
CTRL+SHIFT_	Removes the outline border from the selected cells.
CTRL+SHIFT+~	Applies the General number format.
CTRL+SHIFT+$	Applies the Currency format with two decimal places (negative numbers in parentheses).
CTRL+SHIFT+%	Applies the Percentage format with no decimal places.
CTRL+SHIFT+^	Applies the Exponential number format with two decimal places.
CTRL+SHIFT+#	Applies the Date format with the day, month, and year.
CTRL+SHIFT+@	Applies the Time format with the hour and minute, and AM or PM.
CTRL+SHIFT+!	Applies the Number format with two decimal places, thousands separator, and minus sign (-) for negative values.
CTRL+SHIFT+*	Selects the current region around the active cell (the data area enclosed by blank rows and blank columns). In a PivotTable, it selects the entire PivotTable report.
CTRL+SHIFT+:	Enters the current time.
CTRL+SHIFT+"	Copies the value from the cell above the active cell into the cell or the Formula Bar.
CTRL+SHIFT+Plus (+)	Displays the Insert dialog box to insert blank cells.
CTRL+Minus (-)	Displays the Delete dialog box to delete the selected cells.
CTRL+;	Enters the current date.
CTRL+`	Alternates between displaying cell values and displaying formulas in the worksheet.
CTRL+'	Copies a formula from the cell above the active cell into the cell or the Formula Bar.
CTRL+1	Displays the Format Cells dialog box.
CTRL+2	Applies or removes bold formatting.
CTRL+3	Applies or removes italic formatting.
CTRL+4	Applies or removes underlining.
CTRL+5	Applies or removes strikethrough.
CTRL+6	Alternates between hiding objects, displaying objects, and displaying placeholders for objects.
CTRL+8	Displays or hides the outline symbols.
CTRL+9	Hides the selected rows.
CTRL+0	Hides the selected columns.
CTRL+A	Selects the entire worksheet. If the worksheet contains data, CTRL+A selects the current region. Pressing CTRL+A a second time selects the current region and its summary rows. Pressing CTRL+A a third time selects the entire worksheet. When the insertion point is to the right of a function name in a formula, displays the Function Arguments dialog box. CTRL+SHIFT+A inserts the argument names and parentheses when the insertion point is to the right of a function name in a formula.
CTRL+B	Applies or removes bold formatting.
CTRL+C	Copies the selected cells. CTRL+C followed by another CTRL+C displays the Clipboard.
CTRL+D	Uses the Fill Down command to copy the contents and format of the topmost cell of a selected range into the cells below.
CTRL+F	Displays the Find and Replace dialog box, with the Find tab selected. SHIFT+F5 also displays this tab, while SHIFT+F4 repeats the last Find action. CTRL+SHIFT+F opens the Format Cells dialog box with the Font tab selected.
CTRL+G	Displays the Go To dialog box. F5 also displays this dialog box.
CTRL+H	Displays the Find and Replace dialog box, with the Replace tab selected.
CTRL+I	Applies or removes italic formatting.
CTRL+K	Displays the Insert Hyperlink dialog box for new hyperlinks or the Edit Hyperlink dialog box for selected existing hyperlinks.
CTRL+N	Creates a new, blank workbook.
CTRL+O	Displays the Open dialog box to open or find a file. CTRL+SHIFT+O selects all cells that contain comments.
CTRL+P	Displays the Print dialog box. CTRL+SHIFT+P opens the Format Cells dialog box with the Font tab selected.
CTRL+R	Uses the Fill Right command to copy the contents and format of the leftmost cell of a selected range into the cells to the right.
CTRL+S	Saves the active file with its current file name, location, and file format.
CTRL+T	Displays the Create Table dialog box.
CTRL+U	Applies or removes underlining. CTRL+SHIFT+U switches between expanding and collapsing of the formula bar.
CTRL+V	Inserts the contents of the Clipboard at the insertion point and replaces any selection. Available only after you have cut or copied an object, text, or cell contents. CTRL+ALT+V displays the Paste Special dialog box. Available only after you have cut or copied an object, text, or cell contents on a worksheet or in another program.
CTRL+W	Closes the selected workbook window.
CTRL+X	Cuts the selected cells.
CTRL+Y	Repeats the last command or action, if possible.
CTRL+Z	Uses the Undo command to reverse the last command or to delete the last entry that you typed. CTRL+SHIFT+Z uses the Undo or Redo command to reverse or restore the last automatic correction when AutoCorrect Smart Tags are displayed.

Function keys

Key	Description
F1	Displays the Microsoft Office Excel Help task pane. CTRL+F1 displays or hides the Ribbon, a component of the Microsoft Office Fluent user interface. ALT+F1 creates a chart of the data in the current range. ALT+SHIFT+F1 inserts a new worksheet.
F2	Edits the active cell and positions the insertion point at the end of the cell contents. It also moves the insertion point into the Formula Bar when editing in a cell is turned off. SHIFT+F2 adds or edits a cell comment. CTRL+F2 displays the Print Preview window.
F3	Displays the Paste Name dialog box. SHIFT+F3 displays the Insert Function dialog box.
F4	Repeats the last command or action, if possible. When a cell reference or range is selected in a formula, F4 cycles through the various combinations of absolute and relative references. CTRL+F4 closes the selected workbook window.
F5	Displays the Go To dialog box. CTRL+F5 restores the window size of the selected workbook window.
F6	Switches between the worksheet, Ribbon, task pane, and Zoom controls. In a worksheet that has been split (View menu, Manage This Window, Freeze Panes, Split Window command), F6 includes the split panes when switching between panes and the Ribbon area. SHIFT+F6 switches between the worksheet, Zoom controls, task pane, and Ribbon. CTRL+F6 switches to the next workbook window when more than one workbook window is open.
F7	Displays the Spelling dialog box to check spelling in the active worksheet or selected range. CTRL+F7 performs the Move command on the workbook window when it is not maximized. Use the arrow keys to move the window, and when finished press ENTER, or ESC to cancel.
F8	Turns extend mode on or off. In extend mode, Extended Selection appears in the status line, and the arrow keys extend the selection. SHIFT+F8 enables you to add a nonadjacent cell or range to a selection of cells by using the arrow keys. CTRL+F8 performs the Size command (on the Control menu for the workbook window) when a workbook is not maximized. ALT+F8 displays the Macro dialog box to create, run, edit, or delete a macro.
F9	Calculates all worksheets in all open workbooks. SHIFT+F9 calculates the active worksheet. CTRL+ALT+F9 calculates all worksheets in all open workbooks, regardless of whether they have changed since the last calculation. CTRL+ALT+SHIFT+F9 rechecks dependent formulas, and then calculates all cells in all open workbooks, including cells not marked as needing to be calculated. CTRL+F9 minimizes a workbook window to an icon.
F10	Turns key tips on or off. SHIFT+F10 displays the shortcut menu for a selected item. ALT+SHIFT+F10 displays the menu or message for a smart tag. If more than one smart tag is present, it switches to the next smart tag and displays its menu or message. CTRL+F10 maximizes or restores the selected workbook window.
F11	Creates a chart of the data in the current range. SHIFT+F11 inserts a new worksheet. ALT+F11 opens the Microsoft Visual Basic Editor, in which you can create a macro by using Visual Basic for Applications (VBA).
F12	Displays the Save As dialog box.

Other useful shortcut keys

Key	Description
ARROW KEYS	Move one cell up, down, left, or right in a worksheet. CTRL+ARROW KEY moves to the edge of the current data region in a worksheet. SHIFT+ARROW KEY extends the selection of cells by one cell. CTRL+SHIFT+ARROW KEY extends the selection of cells to the last nonblank cell in the same column or row as the active cell, or if the next cell is blank, extends the selection to the next nonblank cell. LEFT ARROW or RIGHT ARROW selects the tab to the left or right when the Ribbon is selected. When a submenu is open or selected, these arrow keys switch between the main menu and the submenu. When a Ribbon tab is selected, these keys navigate the tab buttons. DOWN ARROW or UP ARROW selects the next or previous command when a menu or submenu is open. When a Ribbon tab is selected, these keys navigate up or down the tab group. In a dialog box, arrow keys move between options in an open drop-down list, or between options in a group of options. DOWN ARROW or ALT+DOWN ARROW opens a selected drop-down list.
BACKSPACE	Deletes one character to the left in the Formula Bar. Also clears the content of the active cell. In cell editing mode, it deletes the character to the left of the insertion point.
DELETE	Removes the cell contents (data and formulas) from selected cells without affecting cell formats or comments. In cell editing mode, it deletes the character to the right of the insertion point.
END	Moves to the cell in the lower-right corner of the window when SCROLL LOCK is turned on. Also selects the last command on the menu when a menu or submenu is visible. CTRL+END moves to the last cell on a worksheet, in the lowest used row of the rightmost used column. If the cursor is in the formula bar, CTRL+END moves the cursor to the end of the text. CTRL+SHIFT+END extends the selection of cells to the last used cell on the worksheet (lower-right corner). If the cursor is in the formula bar, CTRL+SHIFT+END selects all text in the formula bar from the cursor position to the end—this does not affect the height of the formula bar.
ENTER	Completes a cell entry from the cell or the Formula Bar, and selects the cell below (by default). In a data form, it moves to the first field in the next record. Opens a selected menu (press F10 to activate the menu bar) or performs the action for a selected command. In a dialog box, it performs the action for the default command button in the dialog box (the button with the bold outline, often the OK button). ALT+ENTER starts a new line in the same cell. CTRL+ENTER fills the selected cell range with the current entry. SHIFT+ENTER completes a cell entry and selects the cell above.
ESC	Cancels an entry in the cell or Formula Bar. Closes an open menu or submenu, dialog box, or message window. It also closes full screen mode when this mode has been applied, and returns to normal screen mode to display the Ribbon and status bar again.
HOME	Moves to the beginning of a row in a worksheet. Moves to the cell in the upper-left corner of the window when SCROLL LOCK is turned on. Selects the first command on the menu when a menu or submenu is visible. CTRL+HOME moves to the beginning of a worksheet. CTRL+SHIFT+HOME extends the selection of cells to the beginning of the worksheet.
PAGE DOWN	Moves one screen down in a worksheet. ALT+PAGE DOWN moves one screen to the right in a worksheet. CTRL+PAGE DOWN moves to the next sheet in a workbook. CTRL+SHIFT+PAGE DOWN selects the current and next sheet in a workbook.
PAGE UP	Moves one screen up in a worksheet. ALT+PAGE UP moves one screen to the left in a worksheet. CTRL+PAGE UP moves to the previous sheet in a workbook. CTRL+SHIFT+PAGE UP selects the current and previous sheet in a workbook.
SPACEBAR	In a dialog box, performs the action for the selected button, or selects or clears a check box. CTRL+SPACEBAR selects an entire column in a worksheet. SHIFT+SPACEBAR selects an entire row in a worksheet. CTRL+SHIFT+SPACEBAR selects the entire worksheet. If the worksheet contains data, CTRL+SHIFT+SPACEBAR selects the current region. Pressing CTRL+SHIFT+SPACEBAR a second time selects the current region and its summary rows. Pressing CTRL+SHIFT+SPACEBAR a third time selects the entire worksheet. When an object is selected, CTRL+SHIFT+SPACEBAR selects all objects on a worksheet. ALT+SPACEBAR displays the Control menu for the Microsoft Office Excel window.
TAB	Moves one cell to the right in a worksheet. Moves between unlocked cells in a protected worksheet. Moves to the next option or option group in a dialog box. SHIFT+TAB moves to the previous cell in a worksheet or the previous option in a dialog box. CTRL+TAB switches to the next tab in dialog box. CTRL+SHIFT+TAB switches to the previous tab in a dialog box.

Write To MySQL database PHP

To be able to write data to a database and in this case a MySQL database is an efficient way of automating tasks that normally is very time consuming. This VBA Macro code writes new data to am existing MySQL database.

Explanation

The VBA Macro code useful for updating MySQL databases for example if you have website that is developed in PHP the standard database to use is MySQL. In order to make the connection between excel and MySQL you need an ODBC connector for the latest driver check out mysql.com. In the attached excel file available at the bottom of this page there are columns in the file where you add field names. Not all field names need to be added just the ones you are going to write to. The first id field always needs to be there. Fill in data regarding, database name, server name, user id, password and name of table. Add the field names and beneath the data you are going to write to the database. Push the button and if you have installed the ODBC driver correctly and set up the MySQL database correctly you will start writing data to your MySQL database. Enjoy!

Code

Sub WriteToMySQLDatabase()

' For detailed description visit http://www.vbaexcel.eu/

Dim rs As ADODB.Recordset
Dim Cn As ADODB.Connection
Dim Server_Name As String
Dim Database_Name As String
Dim Password As String
Dim SQLStr As String
Dim User_ID As String
Set rs = New ADODB.Recordset
       
Server_Name = Range("e4").Value             ' IP number or servername
Database_Name = Range("e1").Value         ' Name of database
User_ID = Range("h1").Value                      'id user or username
Password = Range("e3").Value                    'Password
Tabellen = Range("e2").Value                     ' Name of table to write to
       
rad = 0
While Range("a6").Offset(rad, 0).Value <> tom
    TextStrang = tom
    kolumn = 0
    While Range("A5").Offset(0, kolumn).Value <> tom
        If kolumn = 0 Then TextStrang = TextStrang & Cells(5, 1) & " = '" & Cells(6 + rad, 1)
        If kolumn <> 0 Then TextStrang = TextStrang & "', " & Cells(5, 1 + kolumn) & " = '" & Cells(6 + rad, 1 + kolumn)
        kolumn = kolumn + 1
    Wend
    TextStrang = TextStrang & "'"
    SQLStr = "INSERT INTO " & Tabellen & " SET " & TextStrang
    Set Cn = New ADODB.Connection
    Cn.Open "Driver={MySQL ODBC 3.51 Driver};Server=" & Server_Name & ";Database=" & Database_Name & _
    ";Uid=" & User_ID & ";Pwd=" & Password & ";"
    Cn.Execute SQLStr
    rad = rad + 1
Wend

Set rs = Nothing
Cn.Close
Set Cn = Nothing

End Sub

Write Text to Word From Excel using VBA

This program opens a word file and writes text into it and customizes the text slightly.

Explanation

The VBA program opens an already existing word file stored on a hard drive and writes text into the file and makes the text bold etc. Afterwards the file is saved and closed and stored at the same location. This function can be used when making own programs for making customized quotations for example when the existing business system is not sufficient. Almost all customization that can be done with the word file is possible to perform using VBA or the template can be customized before writing text to the file.

In order to make the program work the reference “Microsoft Word XX.X Object Library” needs to be enabled.An example file of the VBA code is available for downloading at the end of this page, enjoy! Or just copy and paste the code directly from this web page.

Code

Public Sub Write_Text_to_Word_From_Excel_using_VBA()

Dim Write_Text_to_Word_From_Excel_using_VBA_APP As Word.Application
Dim Write_Text_to_Word_From_Excel_using_VBA_DOC As Word.Document
Set Write_Text_to_Word_From_Excel_using_VBA_APP = CreateObject("Word.Application")

Dim PlaceOfWordFile As String
Dim NameOfWordFile As String

PlaceOfWordFile = Range("B4").Value
NameOfWordFile = Range("B5").Value

NamePlace = PlaceOfWordFile + "\" + NameOfWordFile

Write_Text_to_Word_From_Excel_using_VBA_APP.Visible = True

Set Write_Text_to_Word_From_Excel_using_VBA_DOC = Write_Text_to_Word_From_Excel_using_VBA_APP.Documents.Open(NamePlace, ReadOnly:=False)

Row = 0
While Range("B8").Offset(Row, 0).Value <> tom
    Write_Text_to_Word_From_Excel_using_VBA_APP.Selection.Font.Name = Range("B8").Offset(Row, 2).Value
    Write_Text_to_Word_From_Excel_using_VBA_APP.Selection.Font.Size = Range("B8").Offset(Row, 1).Value
    Write_Text_to_Word_From_Excel_using_VBA_APP.Selection.TypeText Text:=Range("B8").Offset(Row, 0).Value
    Write_Text_to_Word_From_Excel_using_VBA_APP.Selection.TypeParagraph
    Row = Row + 1
Wend

Write_Text_to_Word_From_Excel_using_VBA_DOC.Save
Write_Text_to_Word_From_Excel_using_VBA_APP.Quit

Set Write_Text_to_Word_From_Excel_using_VBA_DOC = Nothing
Set Write_Text_to_Word_From_Excel_using_VBA_APP = Nothing
End Sub

VBA Message Box Yes or No MsgBox

Code for calling a message box with the option Yes or No and depending on the answer different coding is executed.

Explanation

To call a message box with the option Yes or No and depending on the answer different execute different sub programs is good when trying a more interactive approach with the end-user. By using this function you can choose path of the rest of the program if the user answers yes then a certain code is run and if the user answers no another code is run. Simple and clever!

Code

Public Sub MessageBoxYesOrNoMsgBox()

Dim YesOrNoAnswerToMessageBox As String
Dim QuestionToMessageBox As String

    QuestionToMessageBox = "Are you an expert of VBA?"

    YesOrNoAnswerToMessageBox = MsgBox(QuestionToMessageBox, vbYesNo, "VBA Expert or Not")

    If YesOrNoAnswerToMessageBox = vbNo Then
         MsgBox "Learn more VBA!"
    Else
        MsgBox "Congratulations!"
    End If

End Sub

VBA Error Handling On Error Resume Next

This macro code enables the On Error Resume Next function.

Explanation

To enable On Error Resume Next will make the VBA program skip code that generates an error and normally stops the program.A basic example file of the VBA macro is available for download at the bottom of this web page, or just copy and paste the code directly from this page.
In many cases it is done clever to enable the on error resume next function because the bugs in your code will not be easily found. However in some cases when you know that there might appear an error that you want the program to ignore you can disable or enable the function. After the program has run the code lines that is relevant for the problem make sure to enable the function again.

Code

Public Sub Error_Handling_VBA_On_Error_Resume_Next()

'The error function is turned off in case of error just continue
On Error Resume Next

'An error statment is trying to be executed and no error occurs due to On Error Resume Next
Test = 5 / 0

'Normal error handling is turned on again
On Error GoTo 0

End Sub

Update MySQL database PHP

Updating existing data in a MySQL database is easily done by using this VBA Macro code. Many are using the methodology when working with websites developed in PHP and MySQL.

Explanation

This VBA Macro code is optimized for updating an exsisting MySQL database. You need a connector, ODBC for latest version mysql.com download the excel file ate the bottom of this page or copy and paste the code directly. In the file there are some data that needs to be added according to your set up of the MySQL database and connection. Fill in the data and add the required fileds that you are going to update. Push the buttom and you will be updating existing data in your MySQL database. MySQL is one of the most effective databases and the best thing is that it is used free of charge.

Code

Sub UpdateMySQLDatabasePHP()

' For detailed description visit http://www.vbaexcel.eu/

Dim Database_Name As String
Dim User_ID As String
Dim Password As String
Dim Cn As ADODB.Connection
Dim Server_Name As String
Dim SQLStr As String
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
User_ID = Range("h1").Value                      'i d user or username
Password = Range("e3").Value                    ' Password
Server_Name = Range("e4").Value             ' IP number or servername
Database_Name = Range("e1").Value         ' Name of database
Tabellen = Range("e2").Value                     ' Name of table to write to

rad = 0
While Range("a6").Offset(rad, 0).Value <> tom
    TextStrang = tom
    kolumn = 0
    While Range("A5").Offset(0, kolumn).Value <> tom
        If kolumn = 0 Then TextStrang = TextStrang & Cells(5, 1) & " = '" & Cells(6 + rad, 1)
        If kolumn <> 0 Then TextStrang = TextStrang & "', " & Cells(5, 1 + kolumn) & " = '" & Cells(6 + rad, 1 + kolumn)
        kolumn = kolumn + 1
    Wend
    TextStrang = TextStrang & "'"
    SQLStr = "UPDATE " & Tabellen & " SET " & TextStrang & "WHERE " & Cells(5, 1) & " = '" & Cells(6 + rad, 1) & "'"
    Set Cn = New ADODB.Connection
    Cn.Open "Driver={MySQL ODBC 3.51 Driver};Server=" & Server_Name & ";Database=" & Database_Name & _
    ";Uid=" & User_ID & ";Pwd=" & Password & ";"
    Cn.Execute SQLStr
    rad = rad + 1
Wend
Set rs = Nothing
Cn.Close
Set Cn = Nothing

End Sub

Sudoku Solver

A professional tool to be able to solve complex sudoku games. The VBA program uses logic and guess functions to solve the game.

Explanation

Sudoku solver uses basic logic functions and by this approach eliminates possible numbers in certain positions. For complex games it also has a guess function and loops through different solutions until the correct one is found. This sudoku solver will solve all sudokus also the impossible ones or the ones where only one figure is to start with. When starting with a very low number of data the outcome can vary and the program will find different end solutions. In some cases the program tries an approach that fails then the program starts again and finally the right solution is found. The program can be optimized in speed if the visual effects is turned off before executing the program.

Code

Public Sub Sudoku_Solver_One()
'Start program to solve one step
Total = False
Call Sudoku_Solver(Total)
End Sub
Public Sub Sudoku_Solver_Total()
'Start program to solve complete
Total = True
Call Sudoku_Solver(Total)
End Sub

Public Sub Sudoku_Solver(Total)

Range("N3:V11").ClearContents
Range("N3:V11").Interior.ColorIndex = 0

'write_it controls if the program has written anything new to the matrix if not then the guess program is executed
write_it = False

'The array containing all data
Dim Sudoku_Solver(9, 9, 40)

Call ReadInData(Sudoku_Solver)
Call write_itData(Sudoku_Solver, write_it)
Call DetermineReady(Sudoku_Solver)

lups = 0
ER = False
While ER = False
    For Row = 1 To 9
        For Column = 1 To 9
            If Sudoku_Solver(Row, Column, 0) = tom Then
                write_it = False
                'Basic methods for solving Sudoku
                Call QuadrantCheck(Sudoku_Solver, Row, Column, write_it)
                Call RowCheck(Sudoku_Solver, Row, Column, write_it)
                Call ColumnCheck(Sudoku_Solver, Row, Column, write_it)
                Call QuadrantCheckIN(Sudoku_Solver, Row, Column, write_it)
                Call RowCheckIN(Sudoku_Solver, Row, Column, write_it)
                Call ColumnCheckIN(Sudoku_Solver, Row, Column, write_it)
                Call DetermineReady(Sudoku_Solver)
            End If
        Next
    Next

'?!?!

    ReStart = False
    'Searches for errors if the error is found during first run the program ends
    Call CheckError(Sudoku_Solver, ReStart, start)
    If ReStart = True Then
        write_it = True
        Erase Sudoku_Solver
        Call ReadInData(Sudoku_Solver)
        Range("N3:V11").ClearContents
        Call write_itData(Sudoku_Solver, write_it)
        StartAllOver = StartAllOver + 1
        If StartAllOver > 1000 Then
            End
        End If
        If lups = 0 Then
            End
        End If
  
    End If

    If write_it = False Then
        Call Guess(Sudoku_Solver, write_it, StartAllOver)
    End If

    Call DetermineReady(Sudoku_Solver)
    If Total = True Then
        Call write_itData(Sudoku_Solver, write_it)
    End If
    Call CheckReady(Sudoku_Solver, ER)
    lups = lups + 1
Wend

If Total = False Then
    Call WriteOne(Sudoku_Solver)
End If

End Sub

Public Sub ReadInData(Sudoku_Solver)

For Row = 1 To 9
    For Column = 1 To 9
        Sudoku_Solver(Row, Column, 11) = Range("c3").Offset(Row - 1, Column - 1).Value
        Sudoku_Solver(Row, Column, 0) = Range("c3").Offset(Row - 1, Column - 1).Value
        If Sudoku_Solver(Row, Column, 0) = tom Then
            For loops = 1 To 9
                Sudoku_Solver(Row, Column, loops) = 1
            Next
        Else
            For loops = 1 To 9
                Sudoku_Solver(Row, Column, loops) = 0
            Next
        End If

        If Column < 4 Then
            If Row < 4 Then
                Sudoku_Solver(Row, Column, 10) = 1
            End If
            If Row < 7 And Row > 3 Then
                Sudoku_Solver(Row, Column, 10) = 4
            End If
            If Row > 6 Then
                Sudoku_Solver(Row, Column, 10) = 7
            End If
        End If

        If Column < 7 And Column > 3 Then
            If Row < 4 Then
                Sudoku_Solver(Row, Column, 10) = 2
            End If
            If Row < 7 And Row > 3 Then
                Sudoku_Solver(Row, Column, 10) = 5
            End If
            If Row > 6 Then
                Sudoku_Solver(Row, Column, 10) = 8
            End If
        End If

        If Column > 6 Then
            If Row < 4 Then
                Sudoku_Solver(Row, Column, 10) = 3
            End If
            If Row < 7 And Row > 3 Then
                Sudoku_Solver(Row, Column, 10) = 6
            End If
            If Row > 6 Then
                Sudoku_Solver(Row, Column, 10) = 9
            End If
        End If
    Next
Next

End Sub



Public Sub write_itData(Sudoku_Solver, write_it)

For Row = 1 To 9
    For Column = 1 To 9
        If Range("n3").Offset(Row - 1, Column - 1).Value = tom Then
            If Sudoku_Solver(Row, Column, 0) <> tom Then
                Range("n3").Offset(Row - 1, Column - 1).Value = Sudoku_Solver(Row, Column, 0)
                write_it = True
            End If
        End If
    Next
Next

End Sub

Public Sub DetermineReady(Sudoku_Solver)

For Row = 1 To 9
    For Column = 1 To 9
        For värde = 1 To 9
            If Sudoku_Solver(Row, Column, värde) = 1 Then
                antal = antal + 1
                värdeTal = värde
            End If
        Next
        If antal = 1 Then
            Sudoku_Solver(Row, Column, värdeTal) = 0
            Sudoku_Solver(Row, Column, 0) = värdeTal
        End If
        antal = 0
    Next
Next

End Sub

'?!?!

Public Sub QuadrantCheck(Sudoku_Solver, Row, Column, write_it)

kvadrant = Sudoku_Solver(Row, Column, 10)

For RowT = 1 To 9
    For ColumnT = 1 To 9
        If Sudoku_Solver(RowT, ColumnT, 10) = kvadrant Then
            If Sudoku_Solver(RowT, ColumnT, 0) <> tom Then
                tal = Sudoku_Solver(RowT, ColumnT, 0)
            If Sudoku_Solver(Row, Column, tal) = 1 Then
                Sudoku_Solver(Row, Column, tal) = 0
                write_it = True
            End If
            End If
        End If
    Next
Next

End Sub


Public Sub RowCheck(Sudoku_Solver, Row, Column, write_it)

For ColumnT = 1 To 9
    If Sudoku_Solver(Row, ColumnT, 0) <> tom Then
        värdeTal = Sudoku_Solver(Row, ColumnT, 0)
        If Sudoku_Solver(Row, Column, värdeTal) = 1 Then
            Sudoku_Solver(Row, Column, värdeTal) = 0
            write_it = True
        End If
    End If
Next

End Sub

Public Sub ColumnCheck(Sudoku_Solver, Row, Column, write_it)

For RowT = 1 To 9
    If Sudoku_Solver(RowT, Column, 0) <> tom Then
        värdeTal = Sudoku_Solver(RowT, Column, 0)
        If Sudoku_Solver(Row, Column, värdeTal) = 1 Then
            Sudoku_Solver(Row, Column, värdeTal) = 0
            write_it = True
        End If
    End If
Next

End Sub



Public Sub QuadrantCheckIN(Sudoku_Solver, Row, Column, write_it)

kvadrant = Sudoku_Solver(Row, Column, 10)

For värde = 1 To 9
    unik = True
    If Sudoku_Solver(Row, Column, värde) = 1 Then
        For RowT = 1 To 9
            For ColumnT = 1 To 9
                If Sudoku_Solver(RowT, ColumnT, 10) = kvadrant Then
                    If Sudoku_Solver(RowT, ColumnT, 0) = värde Then unik = False
                    If Sudoku_Solver(RowT, ColumnT, värde) = 1 Then
                        If Row = RowT And Column = ColumnT Then
                        Else
                            unik = False
                        End If
                    End If
                End If
            Next
        Next

        If unik = True Then
            Sudoku_Solver(Row, Column, 0) = värde
            write_it = True
            For lups = 1 To 9
                Sudoku_Solver(Row, Column, lups) = 0
            Next
        End If
  End If
Next

End Sub

Public Sub RowCheckIN(Sudoku_Solver, Row, Column, write_it)

For värde = 1 To 9
    unik = True
    If Sudoku_Solver(Row, Column, värde) = 1 Then
        For ColumnT = 1 To 9
            If Sudoku_Solver(Row, ColumnT, 0) = värde Then
                unik = False
            End If
            If Sudoku_Solver(Row, ColumnT, värde) = 1 Then
                If ColumnT <> Column Then
                    unik = False
                End If
            End If
        Next
        If unik = True Then
            Sudoku_Solver(Row, Column, 0) = värde
            write_it = True
            For lups = 1 To 9
                Sudoku_Solver(Row, Column, lups) = 0
            Next
        End If
    End If
Next

End Sub

'?!?!

Public Sub ColumnCheckIN(Sudoku_Solver, Row, Column, write_it)

kvadrant = Sudoku_Solver(Row, Column, 10)

For värde = 1 To 9
    unik = True
    If Sudoku_Solver(Row, Column, värde) = 1 Then
        For RowT = 1 To 9
            If Sudoku_Solver(RowT, Column, 0) = värde Then
                unik = False
            End If
            If Sudoku_Solver(RowT, Column, värde) = 1 Then
                If RowT <> Row Then
                    unik = False
                End If
            End If
        Next
        If unik = True Then
            Sudoku_Solver(Row, Column, 0) = värde
            write_it = True
            For lups = 1 To 9
                Sudoku_Solver(Row, Column, lups) = 0
            Next
        End If
    End If
Next

End Sub

Public Sub Guess(Sudoku_Solver, write_it, StartAllOver)

'identify best guess place

SlutSumma = 10
For Row = 1 To 9
    For Column = 1 To 9
        If Sudoku_Solver(Row, Column, 0) = tom Then
            For lups = 1 To 9
                summa = summa + Sudoku_Solver(Row, Column, lups)
            Next
            If summa < SlutSumma Then
                SlutRow = Row
                SlutColumn = Column
                SlutSumma = summa
            End If
            summa = 0
        End If
    Next
Next

If SlutSumma <> 0 Then
    'Random number between 1 and 9
    hittat = False
    While hittat = False
        Randomize
        tal = Int((9 * Rnd) + 1)
        If Sudoku_Solver(SlutRow, SlutColumn, tal) = 1 Then
            hittat = True
            Sudoku_Solver(SlutRow, SlutColumn, 0) = tal
            For lups = 1 To 9
                Sudoku_Solver(SlutRow, SlutColumn, lups) = 0
                write_it = True
            Next
        End If
    Wend
Else
    Erase Sudoku_Solver
    write_it = True
    Range("N3:V11").ClearContents
    Call ReadInData(Sudoku_Solver)
    Call write_itData(Sudoku_Solver, write_it)
    StartAllOver = StartAllOver + 1
    If StartAllOver > 1000 Then
        End
    End If
End If

'?!?!

End Sub

Public Sub CheckError(Sudoku_Solver, ReStart, start)

Dim R(9)
Dim C(9)

For Value = 1 To 9
    For Row = 1 To 9
        Erase R
        For Column = 1 To 9
            If Sudoku_Solver(Row, Column, 0) <> 0 Then
                R(Sudoku_Solver(Row, Column, 0)) = R(Sudoku_Solver(Row, Column, 0)) + 1
                If R(Sudoku_Solver(Row, Column, 0)) > 1 Then ReStart = True
            End If
        Next
    Next
    For Column2 = 1 To 9
        Erase C
        For Row2 = 1 To 9
            If Sudoku_Solver(Row2, Column2, 0) <> 0 Then
                C(Sudoku_Solver(Row2, Column2, 0)) = C(Sudoku_Solver(Row2, Column2, 0)) + 1
                If C(Sudoku_Solver(Row2, Column2, 0)) > 1 Then ReStart = True
            End If
        Next
    Next
Next

End Sub



Public Sub CheckReady(Sudoku_Solver, ER)

For Row = 1 To 9
    For Column = 1 To 9
        Summan = Summan + Sudoku_Solver(Row, Column, 0)
        If Sudoku_Solver(Row, Column, 0) <> tom Then
            Summan2 = Summan2 + 1
        End If
    Next
Next

If Summan = 405 And Summan2 = 81 Then
    ER = True
End If

End Sub

Public Sub WriteOne(Sudoku_Solver)

OneRandom = False
While OneRandom = False
    Randomize
    Row = Int((9 * Rnd) + 1)
    Column = Int((9 * Rnd) + 1)
    If Sudoku_Solver(Row, Column, 11) = tom Then
        Range("n3").Offset(Row - 1, Column - 1).Value = Sudoku_Solver(Row, Column, 0)
        Range("n3").Offset(Row - 1, Column - 1).Interior.ColorIndex = 4
    OneRandom = True
    End If
Wend

End Sub

Sudoku Games Generator

Soduko Games Generator is a program that generates Sudoku games with chosen difficulty and complexity levels.

Explanation

The program is basically developed and programmed based on the Sudoku Solver (also available here on this site) and the approach is to try to solve a Sudoku without any start values, an empty matrix that is. The program then uses the logic functions and guess functions in order to find a solution for the Sudoku game. You can make sudokus with different difficult levels. Starting with less data makes the sudoku harder to solve but if you enter to few data the result can be that different end solutions can be found all are correct though. Make sure to test the program in the solver and make sure that only one solution can be found before giving the game to friends.

Code

Public Sub Sudoku_Games_Generator()

Range("N3:V11").ClearContents
Range("C3:K11").ClearContents
Range("C14:K22").ClearContents
Range("N14:V22").ClearContents
Range("C25:K33").ClearContents
Range("N25:V33").ClearContents

'The array containing all data
Dim Sudoku_Games_Generator(9, 9, 40)

For lupar2 = 1 To 6
Erase Sudoku_Games_Generator
'Check_Var controls if the program has written anything new to the matrix if not then the guess program is executed
Check_Var = False



Call ReadInData(Sudoku_Games_Generator)

Call ReadyOrNot(Sudoku_Games_Generator)
StartAllOver = 0
lups = 0
ER = False
While ER = False
    For Row = 1 To 9
        For Column = 1 To 9
            If Sudoku_Games_Generator(Row, Column, 0) = tom Then
                Check_Var = False
                'Basic methods for solving Sudoku
                Call CheckQ2(Sudoku_Games_Generator, Row, Column, Check_Var)
                Call CheckR2(Sudoku_Games_Generator, Row, Column, Check_Var)
                Call CheckC2(Sudoku_Games_Generator, Row, Column, Check_Var)
                Call CheckQ2IN(Sudoku_Games_Generator, Row, Column, Check_Var)
                Call CheckR2IN(Sudoku_Games_Generator, Row, Column, Check_Var)
                Call CheckC2IN(Sudoku_Games_Generator, Row, Column, Check_Var)
                Call ReadyOrNot(Sudoku_Games_Generator)
            End If
        Next
    Next
'?!?!

    ReStart = False
    'Searches for errors if the error is found during first run the program ends
    Call CheckError(Sudoku_Games_Generator, ReStart, start)
    If ReStart = True Then
        Check_Var = True
        Erase Sudoku_Games_Generator
        Call ReadInData(Sudoku_Games_Generator)
        StartAllOver = StartAllOver + 1
        If StartAllOver > 1000 Then
            End
        End If
        If lups = 0 Then
            End
        End If
   
    End If

    If Check_Var = False Then
        Call Guess(Sudoku_Games_Generator, Check_Var, StartAllOver)
    End If

    Call ReadyOrNot(Sudoku_Games_Generator)
    Call CheckReady(Sudoku_Games_Generator, ER)
    lups = lups + 1
Wend

Call EraseData(Sudoku_Games_Generator, Range("N1").Value)
Call Check_VarData(Sudoku_Games_Generator, Check_Var, lupar2)
Next

End Sub

Public Sub ReadInData(Sudoku_Games_Generator)

For Row = 1 To 9
    For Column = 1 To 9
        Sudoku_Games_Generator(Row, Column, 11) = tom
        Sudoku_Games_Generator(Row, Column, 0) = tom
        If Sudoku_Games_Generator(Row, Column, 0) = tom Then
            For loops = 1 To 9
                Sudoku_Games_Generator(Row, Column, loops) = 1
            Next
        Else
            For loops = 1 To 9
                Sudoku_Games_Generator(Row, Column, loops) = 0
            Next
        End If

        If Column < 4 Then
            If Row < 4 Then
                Sudoku_Games_Generator(Row, Column, 10) = 1
            End If
            If Row < 7 And Row > 3 Then
                Sudoku_Games_Generator(Row, Column, 10) = 4
            End If
            If Row > 6 Then
                Sudoku_Games_Generator(Row, Column, 10) = 7
            End If
        End If

        If Column < 7 And Column > 3 Then
            If Row < 4 Then
                Sudoku_Games_Generator(Row, Column, 10) = 2
            End If
            If Row < 7 And Row > 3 Then
                Sudoku_Games_Generator(Row, Column, 10) = 5
            End If
            If Row > 6 Then
                Sudoku_Games_Generator(Row, Column, 10) = 8
            End If
        End If

        If Column > 6 Then
            If Row < 4 Then
                Sudoku_Games_Generator(Row, Column, 10) = 3
            End If
            If Row < 7 And Row > 3 Then
                Sudoku_Games_Generator(Row, Column, 10) = 6
            End If
            If Row > 6 Then
                Sudoku_Games_Generator(Row, Column, 10) = 9
            End If
        End If
    Next
Next

End Sub


Public Sub Check_VarData(Sudoku_Games_Generator, Check_Var, lupar2)

If lupar2 = 1 Then
    RowPos = 0
    ColumnPos = 0
End If

If lupar2 = 2 Then
    RowPos = 0
    ColumnPos = 11
End If

If lupar2 = 3 Then
    RowPos = 11
    ColumnPos = 0
End If

If lupar2 = 4 Then
    RowPos = 11
    ColumnPos = 11
End If

'?!?!

If lupar2 = 5 Then
    RowPos = 22
    ColumnPos = 0
End If

If lupar2 = 6 Then
    RowPos = 22
    ColumnPos = 11
End If

For Row = 1 To 9
    For Column = 1 To 9
        If Range("c3").Offset(RowPos - 1 + Row, ColumnPos - 1 + Column).Value = tom Then
            If Sudoku_Games_Generator(Row, Column, 0) <> tom Then
                Range("c3").Offset(RowPos - 1 + Row, ColumnPos - 1 + Column).Value = Sudoku_Games_Generator(Row, Column, 0)
                Check_Var = True
            End If
        End If
    Next
Next

End Sub

Public Sub ReadyOrNot(Sudoku_Games_Generator)

For Row = 1 To 9
    For Column = 1 To 9
        For värde = 1 To 9
            If Sudoku_Games_Generator(Row, Column, värde) = 1 Then
                antal = antal + 1
                värdeTal = värde
            End If
        Next
        If antal = 1 Then
            Sudoku_Games_Generator(Row, Column, värdeTal) = 0
            Sudoku_Games_Generator(Row, Column, 0) = värdeTal
        End If
        antal = 0
    Next
Next

End Sub


Public Sub CheckQ2(Sudoku_Games_Generator, Row, Column, Check_Var)

kvadrant = Sudoku_Games_Generator(Row, Column, 10)

For RowT = 1 To 9
    For ColumnT = 1 To 9
        If Sudoku_Games_Generator(RowT, ColumnT, 10) = kvadrant Then
            If Sudoku_Games_Generator(RowT, ColumnT, 0) <> tom Then
                tal = Sudoku_Games_Generator(RowT, ColumnT, 0)
            If Sudoku_Games_Generator(Row, Column, tal) = 1 Then
                Sudoku_Games_Generator(Row, Column, tal) = 0
                Check_Var = True
            End If
            End If
        End If
    Next
Next

End Sub


Public Sub CheckR2(Sudoku_Games_Generator, Row, Column, Check_Var)

For ColumnT = 1 To 9
    If Sudoku_Games_Generator(Row, ColumnT, 0) <> tom Then
        värdeTal = Sudoku_Games_Generator(Row, ColumnT, 0)
        If Sudoku_Games_Generator(Row, Column, värdeTal) = 1 Then
            Sudoku_Games_Generator(Row, Column, värdeTal) = 0
            Check_Var = True
        End If
    End If
Next

End Sub

Public Sub CheckC2(Sudoku_Games_Generator, Row, Column, Check_Var)

For RowT = 1 To 9
    If Sudoku_Games_Generator(RowT, Column, 0) <> tom Then
        värdeTal = Sudoku_Games_Generator(RowT, Column, 0)
        If Sudoku_Games_Generator(Row, Column, värdeTal) = 1 Then
            Sudoku_Games_Generator(Row, Column, värdeTal) = 0
            Check_Var = True
        End If
    End If
Next

End Sub



Public Sub CheckQ2IN(Sudoku_Games_Generator, Row, Column, Check_Var)

kvadrant = Sudoku_Games_Generator(Row, Column, 10)

For värde = 1 To 9
    unik = True
    If Sudoku_Games_Generator(Row, Column, värde) = 1 Then
        For RowT = 1 To 9
            For ColumnT = 1 To 9
                If Sudoku_Games_Generator(RowT, ColumnT, 10) = kvadrant Then
                    If Sudoku_Games_Generator(RowT, ColumnT, 0) = värde Then unik = False
                    If Sudoku_Games_Generator(RowT, ColumnT, värde) = 1 Then
                        If Row = RowT And Column = ColumnT Then
                        Else
                            unik = False
                        End If
                    End If
                End If
            Next
        Next

        If unik = True Then
            Sudoku_Games_Generator(Row, Column, 0) = värde
            Check_Var = True
            For lups = 1 To 9
                Sudoku_Games_Generator(Row, Column, lups) = 0
            Next
        End If
  End If
Next

End Sub
'?!?!
Public Sub CheckR2IN(Sudoku_Games_Generator, Row, Column, Check_Var)

For värde = 1 To 9
    unik = True
    If Sudoku_Games_Generator(Row, Column, värde) = 1 Then
        For ColumnT = 1 To 9
            If Sudoku_Games_Generator(Row, ColumnT, 0) = värde Then
                unik = False
            End If
            If Sudoku_Games_Generator(Row, ColumnT, värde) = 1 Then
                If ColumnT <> Column Then
                    unik = False
                End If
            End If
        Next
        If unik = True Then
            Sudoku_Games_Generator(Row, Column, 0) = värde
            Check_Var = True
            For lups = 1 To 9
                Sudoku_Games_Generator(Row, Column, lups) = 0
            Next
        End If
    End If
Next

End Sub

Public Sub CheckC2IN(Sudoku_Games_Generator, Row, Column, Check_Var)

kvadrant = Sudoku_Games_Generator(Row, Column, 10)

For värde = 1 To 9
    unik = True
    If Sudoku_Games_Generator(Row, Column, värde) = 1 Then
        For RowT = 1 To 9
            If Sudoku_Games_Generator(RowT, Column, 0) = värde Then
                unik = False
            End If
            If Sudoku_Games_Generator(RowT, Column, värde) = 1 Then
                If RowT <> Row Then
                    unik = False
                End If
            End If
        Next
        If unik = True Then



            Sudoku_Games_Generator(Row, Column, 0) = värde
            Check_Var = True
            For lups = 1 To 9
                Sudoku_Games_Generator(Row, Column, lups) = 0
            Next
        End If
    End If
Next

End Sub

Public Sub Guess(Sudoku_Games_Generator, Check_Var, StartAllOver)

'identify best guess place

SlutSumma = 10
For Row = 1 To 9
    For Column = 1 To 9
        If Sudoku_Games_Generator(Row, Column, 0) = tom Then
            For lups = 1 To 9
                summa = summa + Sudoku_Games_Generator(Row, Column, lups)
            Next
            If summa < SlutSumma Then
                SlutRow = Row
                SlutColumn = Column
                SlutSumma = summa
            End If
            summa = 0
        End If
    Next
Next
'?!?!
If SlutSumma <> 0 Then
    'Random number between 1 and 9
    hittat = False
    While hittat = False
        Randomize
        tal = Int((9 * Rnd) + 1)
        If Sudoku_Games_Generator(SlutRow, SlutColumn, tal) = 1 Then
            hittat = True
            Sudoku_Games_Generator(SlutRow, SlutColumn, 0) = tal
            For lups = 1 To 9
                Sudoku_Games_Generator(SlutRow, SlutColumn, lups) = 0
                Check_Var = True
            Next
        End If
    Wend
Else
    Erase Sudoku_Games_Generator
    Check_Var = True
    Call ReadInData(Sudoku_Games_Generator)
    StartAllOver = StartAllOver + 1
    If StartAllOver > 1000 Then
        End
    End If
End If

End Sub

Public Sub CheckError(Sudoku_Games_Generator, ReStart, start)

Dim R(9)
Dim C(9)

For Value = 1 To 9
    For Row = 1 To 9
        Erase R
        For Column = 1 To 9
            If Sudoku_Games_Generator(Row, Column, 0) <> 0 Then
                R(Sudoku_Games_Generator(Row, Column, 0)) = R(Sudoku_Games_Generator(Row, Column, 0)) + 1
                If R(Sudoku_Games_Generator(Row, Column, 0)) > 1 Then ReStart = True
            End If
        Next
    Next
    For Column2 = 1 To 9
        Erase C
        For Row2 = 1 To 9
            If Sudoku_Games_Generator(Row2, Column2, 0) <> 0 Then
                C(Sudoku_Games_Generator(Row2, Column2, 0)) = C(Sudoku_Games_Generator(Row2, Column2, 0)) + 1
                If C(Sudoku_Games_Generator(Row2, Column2, 0)) > 1 Then ReStart = True
            End If
        Next
    Next
Next

End Sub



Public Sub CheckReady(Sudoku_Games_Generator, ER)

For Row = 1 To 9
    For Column = 1 To 9
        Summan = Summan + Sudoku_Games_Generator(Row, Column, 0)
        If Sudoku_Games_Generator(Row, Column, 0) <> tom Then
            Summan2 = Summan2 + 1
        End If
    Next
Next

If Summan = 405 And Summan2 = 81 Then
    ER = True
End If

End Sub

Public Sub EraseData(Sudoku_Games_Generator, EraseNumber)

While rounds <> (EraseNumber * 10)
    Randomize
    Row = Int((9 * Rnd) + 1)
    Randomize
    Column = Int((9 * Rnd) + 1)
    If Sudoku_Games_Generator(Row, Column, 0) <> tom Then
        Sudoku_Games_Generator(Row, Column, 0) = tom
        rounds = rounds + 1
    End If
Wend

End Sub

Stop and Wait While Executing VBA Code

This programs stops and waits for a few seconds in the middle of the execution of the VBA code.

Explanation

Sometimes it is useful to stop the coding for a few seconds due to processes that needs to be finalized that are not directly connected and in interaction with the VBA engine, thus will make the program crash if they are not finalized before executing the rest of the VBA program. For example if you have a program that you can execute through VBA macro but it is not fully integrated with excel thus you do not know when the other program has performed their processes. But you might know that the maximum time for finish is 10 seconds then you simply stop your VBA code for 10 seconds and then you can continue the code again!

Code

Public Sub

‘Stops the execution of the code and continues after 10 seconds.
 Application.Wait Now + TimeValue("00:00:10")

End sub

Rnd Random Function

Rnd Random function is a short code snippet that shows how the useful Rnd Random function VBA macro is working.

Explanation

The program randomly changes the colorindex in the cells in the excel sheet, the cell is also chosen randomly by selecting a random column and a random row within a predefined range. The random function is actually never totally random as today the human cannot create a random function that is 100% random it is always based on some kind of samples of data and based on the sample numbers are executed. This approach will create loops and making data reappear systematically.

Code

Sub Random_FunctionRND()

For lups = 1 To 10000
    Randomize
    Color2 = Int((50 * Rnd) + 1)
    Row = Int((25 * Rnd) + 1)
    Column = Int((25 * Rnd) + 1)
    Range("G2").Offset(Row - 1, Column - 1).Interior.ColorIndex = Color2
Next

End Sub

Read Text File Fetch Data

This code snippet reads a text file and fetches the data into the worksheet.

Explanation

This short program extracts the text stored in a predefined text file in predefined folder or directory. The program can be modify to loop through many text files by using the "List files in directory" code, this requires modification by yourself. When making programs that store data in text files not real databases this comes in handy. If you do not perform many database calls per seconds it is ok to use text files as database.

Code

Public Sub ReadTextFileFetchData()

Dim NameOfFile As String
Dim PlaceOfFile As String
Dim Filelocation As String

NameOfFile = Range("c6").Value
PlaceOfFile = Range("c5").Value
Filelocation = PlaceOfFile + "\" + NameOfFile
sText = ReadTextFileFetchDataMain(Filelocation)
Range("c10").Value = sText

End Sub


Function ReadTextFileFetchDataMain(ReadTextFile As String) As String
Dim ReadTextFileSource As Integer
Dim ReadTextFile2 As String

'Closes text files that might be opened
Close
'The number of the next free text file
ReadTextFileSource = FreeFile
Open ReadTextFile For Input As #ReadTextFileSource
ReadTextFile2 = Input$(LOF(1), 1)
Close
ReadTextFileFetchDataMain = ReadTextFile2
End Function

Open Close Save As Word File

This program opens a word file on a predefined location and saves the file with another name to another place.

Explanation

In order to make the program work the reference “Microsoft Word XX.X Object Library” needs to be enabled.
The program opens a word file on a predefined place and saves the file with another name to another place. This can be useful when making quotations or other processes that need customization with text from different databases. The communication between word and excel is fully supported.

Code

Sub Open_Close_Save_As_Word_File()

Dim Open_Close_Save_As_Word_File_APP As Word.Application
Dim Open_Close_Save_As_Word_File_DOC As Word.Document
Set Open_Close_Save_As_Word_File_APP = CreateObject("Word.Application")

Dim PlaceOfWordFile As String
Dim NameOfWordFile As String
Dim NewPlaceOfWordFile As String
Dim NewNameOfWordFile As String

PlaceOfWordFile = Range("B4").Value
NameOfWordFile = Range("B5").Value
NewPlaceOfWordFile = Range("B6").Value
NewNameOfWordFile = Range("B7").Value

NamePlace = PlaceOfWordFile + "\" + NameOfWordFile
NewNamePlace = NewPlaceOfWordFile + "\" + NewNameOfWordFile

Open_Close_Save_As_Word_File_APP.Visible = True
Set Open_Close_Save_As_Word_File_DOC = Open_Close_Save_As_Word_File_APP.Documents.Open(NamePlace, ReadOnly:=True)

Open_Close_Save_As_Word_File_DOC.SaveAs (NewNamePlace)
Open_Close_Save_As_Word_File_APP.Quit

Set Open_Close_Save_As_Word_File_DOC = Nothing
Set Open_Close_Save_As_Word_File_APP = Nothing

End Sub

Manual, Semi Automatic and Automatic Calculation or Call Calculation in VBA

A program for setting the calculation options or calling the calculation on demand.

Explanation

To be able to calculate only on demand can be time saving in some situation when writing figures to the excel sheet if it contains a lot of formulas then it can be good to set the calculation option to manual. On the other hand if combining code with formulas the formulas needs to be updated before data is extracted from the sheet, then it is good to be able to call the calculate on demand. Normally if you only have a small number of formulas then this function is not relevant but for large scale formulas then is very good if you want to speed optimize your program.

Code

Public Sub Manual_Semi_Automatic_and_Automatic_Calculation_or_Call_Calculation_in_VBA ()

If range(“C5”).value=1 then
Application.Calculation = xlAutomatic
End if

If range(“C5”).value=1 then
Application.Calculation = xlSemiautomatic
End if

If range(“C5”).value=1 then
Application.Calculation = xlManual

End sub

Public Sub Calculate_On_Demand_VBA ()

Calculate

End sub

Make Excel Invisible and Hide Excel

The code makes excel invisible for 10 seconds and then excel will get visible again.

Explanation

The code makes excel invisible for 10 seconds, this might be useful in some situations, and then excel will get visible again. The entire program will be invisible thus make sure to make excel visible again because otherwise you will not be able to change this setting back without terminating the program in other ways.

Code

Public Sub HideExcelMakeExcelInvisible()

’Makes the excel invisible.
Application.Visible = False

’In order to be able to get back to excel there is a waiting time for 10 seconds then the application will be visible again.
Application.Wait Now + TimeValue("00:00:10")

’Makes the excel visible again.
Application.Visible = True

End Sub

List Files In Directory

A simple program for listing all files in a certain directory by calling a VBA Macro Code.

Explanation

The program is set up by giving input about which folder/directory that the program shall analyse. The VBA program then uses the Dir function to get the information about what files are stored in the folder/directory. Then the program simply writes the data to the worksheet. It is possible to use the data in an array if wanting to modify and use the code in an other program. This is a good function when you need to write something or perform an operation to all files stored in a certain folder but you do not know exactly what the files are called or how many they are.

Code

Public Sub List_Files_In_Directory()

Range("A5:A2000").ClearContents

Dim List_Files_In_Directory(10000, 1)
Dim One_File_List   As String
Dim Number_Of_Files_In_Directory As Long

One_File_List = Dir$("C:" + "\*.*")
Do While One_File_List <> ""
    List_Files_In_Directory(Number_Of_Files_In_Directory, 0) = One_File_List
    One_File_List = Dir$
    Number_Of_Files_In_Directory = Number_Of_Files_In_Directory + 1
Loop

Number_Of_Files_In_Directory = 0
While List_Files_In_Directory(Number_Of_Files_In_Directory, 0) <> tom
    Range("A5").Offset(Number_Of_Files_In_Directory, 0).Value = List_Files_In_Directory(Number_Of_Files_In_Directory, 0)
    Number_Of_Files_In_Directory = Number_Of_Files_In_Directory + 1
Wend

End Sub

Insert Image to Word, Resize Image, Insert Borders using VBA Excel

The program inserts an image to a word file and resizes the images and inserts a border.

Explanation

This VBA program is developed to extract an image and insert it to word file resize the image according the settings in the worksheet and surround the image with a border. The image can be re-sized using this code but the image will not change in terms of size in kilobytes. To compress an image using VBA is not possible this has to be done manually.

In order to make the program work the reference “Microsoft Word XX.X Object Library” needs to be enabled.Example file of the VBA code is available for downloading at the bottom of this web page, enjoy! Or just copy and paste the code directly from this page.

Code

Public Sub Insert_Image_to_Word_Resize_Image_Insert_Borders_using_VBA_Excel()

Dim Insert_Image_to_Word_Resize_Image_Insert_Borders_using_VBA_Excel_APP As Word.Application
Dim Insert_Image_to_Word_Resize_Image_Insert_Borders_using_VBA_Excel_DOC As Word.Document
Set Insert_Image_to_Word_Resize_Image_Insert_Borders_using_VBA_Excel_APP = CreateObject("Word.Application")

Dim PlaceOfWordFile As String
Dim NameOfWordFile As String

PlaceOfWordFile = Range("B4").Value
NameOfWordFile = Range("B5").Value

PlaceOfImageFile = Range("B6").Value
NameOfImageFile = Range("B7").Value

NamePlaceImage = PlaceOfImageFile + "\" + NameOfImageFile
NamePlace = PlaceOfWordFile + "\" + NameOfWordFile

Insert_Image_to_Word_Resize_Image_Insert_Borders_using_VBA_Excel_APP.Visible = True

Set Insert_Image_to_Word_Resize_Image_Insert_Borders_using_VBA_Excel_DOC = Insert_Image_to_Word_Resize_Image_Insert_Borders_using_VBA_Excel_APP.Documents.Open(NamePlace, ReadOnly:=False)

Set WORD_Image = Insert_Image_to_Word_Resize_Image_Insert_Borders_using_VBA_Excel_APP.Selection.InlineShapes.AddPicture(NamePlaceImage, False, True)
   
HeightOfImage = Range("D5").Value
   
With WORD_Image
    H = .Height
    B = .Width
    Ratio = H / B
    .Height = HeightOfImage
    .Width = HeightOfImage / Ratio
End With

WORD_Image.Borders.OutsideLineStyle = wdLineStyleSingle

Insert_Image_to_Word_Resize_Image_Insert_Borders_using_VBA_Excel_DOC.Save
Insert_Image_to_Word_Resize_Image_Insert_Borders_using_VBA_Excel_APP.Quit

Set Insert_Image_to_Word_Resize_Image_Insert_Borders_using_VBA_Excel_DOC = Nothing
Set Insert_Image_to_Word_Resize_Image_Insert_Borders_using_VBA_Excel_APP = Nothing

End Sub