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

Google Translate by Internet Explorer Automation

This VBA Macro Code translates text using Google Translate by automation of Internet Explorer controlled through Excel.

Explanation

The program automatically writes text from Excel into Internet Explorer and uses the Google Translate service to translate the text into desires language. It is possible to translate from and to many different languages, just change the language code and the program is set up accordingly. Today all the major languages are available using google translate. It is one of few services that enables translation of entire sentences not just words. The service is free of charge and can be executed through API. The exact technology used for the translation is not public. Google has started to translate entire web pages on the internet as well when using the google seach function.  

Code

Public Sub Google_Translate()

Dim Google_Translate_Internet_Explorer_Automation As Object
Set Google_Translate_Internet_Explorer_Automation = CreateObject("InternetExplorer.Application")
Google_Translate_Internet_Explorer_Automation.Navigate "http://translate.google.com/translate_t#"
Google_Translate_Internet_Explorer_Automation.Visible = True
Wait_Between_Google_Translate_Cycles = Range("G1").Value

Column = 0
While Range("f9").Offset(0, Column).Value <> tom

    Do While Google_Translate_Internet_Explorer_Automation.busy
        Call WaitSeconds(Wait_Between_Google_Translate_Cycles)
    Loop
   
    to_language_code = Range("f9").Offset(0, Column).Value

    Do While Google_Translate_Internet_Explorer_Automation.busy
        Call WaitSeconds(Wait_Between_Google_Translate_Cycles)
    Loop

    Google_Translate_Internet_Explorer_Automation.document.forms("text_form").elements(5).Value = to_language_code

    Do While Google_Translate_Internet_Explorer_Automation.busy
        Call WaitSeconds(Wait_Between_Google_Translate_Cycles)
    Loop

    rad = 0
    While Range("c10").Offset(rad, 0).Value <> tom

        If Range("f10").Offset(rad, Column).Value = tom Then

            from_language_code = Range("a10").Offset(rad, 0).Value
            Google_Translate_Internet_Explorer_Automation.document.forms("text_form").elements(4).Value = from_language_code

            Do While Google_Translate_Internet_Explorer_Automation.busy
                Call WaitSeconds(Wait_Between_Google_Translate_Cycles)
            Loop

            Google_Translate_Text = Range("c10").Offset(rad, 0).Value

            While Google_Translate_Internet_Explorer_Automation.busy
                Call WaitSeconds(Wait_Between_Google_Translate_Cycles)
            Wend

            Google_Translate_Internet_Explorer_Automation.document.forms("text_form").elements("source").Value = Google_Translate_Text

            While Google_Translate_Internet_Explorer_Automation.busy
                Call WaitSeconds(Wait_Between_Google_Translate_Cycles)
            Wend

            Google_Translate_Internet_Explorer_Automation.document.getElementById("text_form").submit

            While Google_Translate_Internet_Explorer_Automation.busy
                Call WaitSeconds(Wait_Between_Google_Translate_Cycles)
            Wend

            dd2 = Google_Translate_Internet_Explorer_Automation.document.forms(1).elements(4).Value

            While Google_Translate_Internet_Explorer_Automation.busy
                Call WaitSeconds(Wait_Between_Google_Translate_Cycles)
            Wend

            Google_Translate_Variable1 = Replace(dd2, Chr(13), "")
            Range("f10").Offset(rad, Column).Value = Google_Translate_Variable1

        End If

        rad = rad + 1
    Wend

    Column = Column + 1
Wend

Google_Translate_Internet_Explorer_Automation.Quit
Set Google_Translate_Internet_Explorer_Automation = Nothing

End Sub

Public Sub WaitSeconds(sek)

newHour = Hour(Now())
newMinute = Minute(Now())
newSecond = Second(Now()) + sek
waitTime = TimeSerial(newHour, newMinute, newSecond)
Application.Wait waitTime

End Sub

Extract, Get Data from MySQL PHP

This VBA Macro code extracts data from a MySQL Database and writes the data to an excel file. Many use this for large quantities of data control for PHP web development.

Explanation

The approach is straight forward. Download the file fill in the data regarding set up of MySQL connection. Push the button and all data from the selected table will be displayed. This program is good to use if you have a MySQL database from a website for example and you need to perform a massive amount of data update. Simply automate the process and get the data you need.
To be able to run the VBA Macro code make sure you have enabled the Microsoft ActiveX Data Objects X.X Library. Also a ODBC connector check mysql.com needs to be installed on your computer. 

Code

Sub ExtractDataFromMySQL()

Dim Password As String
Dim SQLStr As String
Dim Cn As ADODB.Connection
Dim Server_Name As String
Dim User_ID As String
Dim Database_Name As String
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
   
Range("a5:bb60000").ClearContents

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

SQLStr = "SELECT * FROM " & Tabellen
   
Set Cn = New ADODB.Connection
Cn.Open "Driver={MySQL ODBC 3.51 Driver};Server=" & Server_Name & ";Database=" & Database_Name & _
";Uid=" & User_ID & ";Pwd=" & Password & ";"
   
rs.Open SQLStr, Cn, adOpenStatic
  
Dim myArray()

myArray = rs.GetRows()
 
kolumner = UBound(myArray, 1)
rader = UBound(myArray, 2)

For K = 0 To kolumner

Range("A5").Offset(0, K).Value = rs.Fields(K).Name
For R = 0 To rader
 Range("A5").Offset(R + 1, K).Value = myArray(K, R)
Next
Next

rs.Close
Set rs = Nothing
Cn.Close
Set Cn = Nothing

End Sub

Email Sender VBA Outlook

Email Sender VBA Outlook is an emailing program that sends emails by communicating with Microsoft Outlook.

Explanation

Email Sender VBA Outlook is a VBA Excel program that communicates with Microsoft Outlook. The program sends email templates from a predefined place on you computer, the file needs to be an .oft-file. There is also a function for blocking certain email addresses. The program requires the reference “Microsoft Outlook XX.X Object Library” to be enabled. In the new version of office it is easy to block communication between excel and outlook make sure to enable the communication before trying the code otherwise it will not work

Code

Sub Email_Sender_VBA_Microsoft_Outlook()

Dim NoMailList(1500)
Call LoadNoMailList(NoMailList)

WaitTimeSecondsBetweenMail = Range("c4").Value
PlaceToStoreEmailTemplate = Range("c5").Value

RowA = 0
While Range("A14").Offset(RowA, 0).Value <> tom
    ToAdress = Range("c14").Offset(RowA, 0).Value
    Subject = Range("d14").Offset(RowA, 0).Value
    FileName = Range("D14").Offset(RowA, 0).Value
    Call WaitTimeProgram(WaitTimeSecondsBetweenMail)
    Subject = Range("e14").Offset(RowA, 0).Value
    Call MatchAdressWithNoMailList(ToAdress, Funnen, NoMailList)
    If Funnen = False Then
        Call EmailSenderProgram(ToAdress, FileName, Subject, PlaceToStoreEmailTemplate)
    End If
    RowA = RowA + 1
Wend

End Sub

Sub EmailSenderProgram(ToAdress, FileName, Subject, PlaceToStoreEmailTemplate)

Dim VBAOutlookEmailSend As Object, vItem As Object, vStr As String
Set VBAOutlookEmailSend = CreateObject("Outlook.Application")
Dim temp2 As String
temp2 = FileName
Set vItem = VBAOutlookEmailSend.CreateItemFromTemplate(PlaceToStoreEmailTemplate + temp2 + ".oft")
vItem.Subject = Subject
Dim ToContact As Outlook.Recipient
Set ToContact = vItem.Recipients.Add(ToAdress)
vItem.ReadReceiptRequested = False
vItem.Send
Set vItem = Nothing
Set VBAOutlookEmailSend = Nothing

End Sub

Public Sub LoadNoMailList(NoMailList)

rad = 0
While Range("g14").Offset(rad, 0).Value <> tom
    NoMailList(rad + 1) = Range("g14").Offset(rad, 0).Value
    rad = rad + 1
Wend

End Sub

Public Sub MatchAdressWithNoMailList(ToAdress, Funnen, NoMailList)

Funnen = False
plats = 1
While NoMailList(plats) <> tom
    komp = InStr(ToAdress, NoMailList(plats))
    If komp <> 0 Then Funnen = True
    plats = plats + 1
Wend

End Sub

Public Sub WaitTimeProgram(sek)

newHour = Hour(Now())
newMinute = Minute(Now())
newSecond = Second(Now()) + sek
waitTime = TimeSerial(newHour, newMinute, newSecond)
Application.Wait waitTime

End Sub

Determine If File or Directory Exists

The VBA Macro determines if a file or directory exists.

Explanation

To be able to determine if a file or directory exists can be useful in some coding situations. This code is a straight forward approach that logs if a error occurs when trying to use the GetAttr() if a error occurs then the file or directory clearly does not exist. This function is useful when you want to communicate or write to a certain file and you are uncertain if the file really exists and if you refer the file you might crash the program, thus check if the file exist if it does communicate with the file or terminate the program. 

Code

Public Sub DetermineIfFileDirectoryExists()
    
Dim DetermineFileExists As Integer
Dim PathOfName As String
    
Range("C8").Value = ""
Range("C8").Interior.ColorIndex = 0
    
' If the file does not exist the program will log an error
On Error Resume Next
PathOfName = Range("C5").Value + "\" + Range("C6").Value
   
DetermineFileExists = GetAttr(PathOfName)
    
Select Case Err.Number
Case Is = 0
    Range("C8").Value = "The File or Directory Exists"
    Range("C8").Interior.ColorIndex = 4
Case Else
    Range("C8").Value = "The File or Directory does NOT Exists"
    Range("C8").Interior.ColorIndex = 3
End Select
   
On Error GoTo 0
End Sub

Database connection, retrieve data from database, querying data into excel using VBA DAO

The VBA code makes a database connection and retrieves data by calling and giving input to existing database query.

Explanation

A database connection is established through the VBA Macro and a query that is all ready created and stored in the database is executed. The query is also created to retrieve data of two different parameters. The parameters can be excluded in case of retrieving all data from a query without specific filters. This type of database connection can be established to all major business systems and can save time and money by eliminating time consuming manual data transfer. For example a days manual work can easily be done automatically using VBA macro automation. It is important to perform analyzes of your own work continuously in order to be efficient.

In order to make the VBA code work the following reference needs to be enabled “Microsoft DAO 3.6 Object Library”.

The entire VBA program can be downloaded in an excel file at the end of this web page or just copy and paste the code directly from the page!

Code

Public Sub database_connection_retrieve_data_from_database_querying_data_into_excel_using_VBA_DAO()

Dim Database_RetrieveData_VBA_Excel As String
Dim Query_RetrieveData_VBA_Excel As String
Dim Parameter1_RetrieveData_VBA_Excel As String
Dim Parameter2_RetrieveData_VBA_Excel As String
Dim DAO_Connection_RetrieveData_VBA_Excel As String
   
Database_RetrieveData_VBA_Excel = Range("G3").Value
Query_RetrieveData_VBA_Excel = Range("G4").Value
Parameter1_RetrieveData_VBA_Excel = Range("G5").Value
Parameter2_RetrieveData_VBA_Excel = Range("G6").Value
DAO_Connection_RetrieveData_VBA_Excel = 0
   
DB1 = DBEngine.OpenDatabase(Database_RetrieveData_VBA_Excel)

Set QD1 = DB1.QueryDefs(Query_RetrieveData_VBA_Excel)
       
QD1.Parameters("p1") = Parameter1_RetrieveData_VBA_Excel
QD1.Parameters("p2") = Parameter2_RetrieveData_VBA_Excel
        
Set RS1 = QD1.OpenRecordset(dbOpenSnapshot, dbReadOnly)
Range("b11").Offset(0, 0).CopyFromRecordset RS1

RS1.Close
QD1.Close
DB1.Close


End Sub

Merge data from all workbooks in a folder

Code Examples that use DIR

There are four basic examples:
1) Merge a range from all workbooks in a folder (below each other)
2) Merge a range from every workbook you select (below each other)
3) Merge a range from all workbooks in a folder (next to each other)
4) Merge a range from all workbooks in a folder with AutoFilter

The code will create a new workbook for you with the data from all workbooks
with in column A or in row 1 the file name of the data in that row or column.
It is up to you if you save the workbook.

Information and Tips

The examples below are only working for one folder (no option for subfolders).
Note: the workbook with the code must be outside the merge folder

Tip 1: Useful Workbooks.Open arguments

Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum), _
Password:="ron", WriteResPassword:="ron", UpdateLinks:=0)

If your workbooks are protected you can us this in the Workbooks.Open arguments
Password:="ron” and WriteResPassword:="ron"

If you have links in your workbook this (UpdateLinks:=0) will avoid the message
do you want to update the links or not "0 Doesn't update any references"
Use 3 instead of 0 if you want to update the links.

See the VBA help for more information about the Workbooks.Open arguments

Tip 2: merge from all Files with a name that start with for example week
Use this then
FilesInPath = Dir(MyPath & "week*.xl*")


Tip 3 : Copy values and formats

the macro examples below will copy only the values, if you want to copy
the formats also replace this :

With SourceRange
    Set destrange = destrange. _
                    Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = SourceRange.Value

With

SourceRange.Copy
With destrange
    .PasteSpecial xlPasteValues
    .PasteSpecial xlPasteFormats
    Application.CutCopyMode = False
End With

Before you restore ScreenUpdating, Calculation and EnableEvents also add this line

Application.Goto BaseWks.Cells(1)




Merge a range from all workbooks in a folder (below each other)

There are a few things you must change before you can run the code

Fill in the path to the folder
MyPath = "C:\Users\Ron\test"

I use the first worksheet of each workbook in my example (index 1)
Change the worksheet index or fill in a sheet name: mybook.Worksheets("YourSheetName")
And change the range A1:C1 to your range

With mybook.Worksheets(1)
    Set SourceRange = .Range("A1:C1")
End With

If you want to copy all cells from the worksheet or from A2 till the last cell on the worksheet.
Then replace the code above with this

With mybook.Worksheets(1)
    FirstCell = "A2"
    Set SourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells))
    'Test if the row of the last cell >= then the row of the FirstCell
    If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then
         Set SourceRange = Nothing
    End If
End With

Add also this dim line at the top of the macro
Dim FirstCell As String

Note: the code above use the function RDB_Last, copy this function also in your code module
if you use it. You find the function in the last section of this page.

Fill in the first cell here and the code will find the last cell on the worksheet for you.
FirstCell = "A2"

Sub Basic_Example_1()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, Fnum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long

    'Fill in the path\folder where the files are
    MyPath = "C:\Users\Ron\test"

    'Add a slash at the end if the user forget it
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    'If there are no Excel files in the folder exit the sub
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If

    'Fill the array(myFiles)with the list of Excel files in the folder
    Fnum = 0
    Do While FilesInPath <> ""
        Fnum = Fnum + 1
        ReDim Preserve MyFiles(1 To Fnum)
        MyFiles(Fnum) = FilesInPath
        FilesInPath = Dir()
    Loop

    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Add a new workbook with one sheet
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    rnum = 1

    'Loop through all files in the array(myFiles)
    If Fnum > 0 Then
        For Fnum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
            On Error GoTo 0

            If Not mybook Is Nothing Then

                On Error Resume Next

                With mybook.Worksheets(1)
                    Set sourceRange = .Range("A1:C1")
                End With

                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    'if SourceRange use all columns then skip this file
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0

                If Not sourceRange Is Nothing Then

                    SourceRcount = sourceRange.Rows.Count

                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "Sorry there are not enough rows in the sheet"
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else

                        'Copy the file name in column A
                        With sourceRange
                            BaseWks.cells(rnum, "A"). _
                                    Resize(.Rows.Count).Value = MyFiles(Fnum)
                        End With

                        'Set the destrange
                        Set destrange = BaseWks.Range("B" & rnum)

                        'we copy the values from the sourceRange to the destrange
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value

                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If

        Next Fnum
        BaseWks.Columns.AutoFit
    End If

ExitTheSub:
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

Merge a range from every workbook you select (below each other)

This code example will do the same as the example above only when you run the code
you are able to select the files you want to merge.

Fill in the path to the folder
ChDirNet "C:\Users\Ron\test"

and change the sheet and range to yours (see first example)

It is also possible to set the start folder with ChDrive and ChDir but I choose to use the
SetCurrentDirectoryA  function in this example because it also is working with network folders.


Note: Copy all code below in a normal module

#If VBA7 Then
    Declare PtrSafe Function SetCurrentDirectoryA Lib _
    "kernel32" (ByVal lpPathName As String) As Long
#Else
    Declare Function SetCurrentDirectoryA Lib _
    "kernel32" (ByVal lpPathName As String) As Long
#End If


Sub ChDirNet(szPath As String)
    SetCurrentDirectoryA szPath
End Sub

Sub Basic_Example_2()
    Dim MyPath As String
    Dim SourceRcount As Long, Fnum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long
    Dim SaveDriveDir As String
    Dim FName As Variant


    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    SaveDriveDir = CurDir
    ChDirNet "C:\Users\Ron\test"

    FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
                                        MultiSelect:=True)
    If IsArray(FName) Then

        'Add a new workbook with one sheet
        Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
        rnum = 1


        'Loop through all files in the array(myFiles)
        For Fnum = LBound(FName) To UBound(FName)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(FName(Fnum))
            On Error GoTo 0

            If Not mybook Is Nothing Then

                On Error Resume Next
                With mybook.Worksheets(1)
                    Set sourceRange = .Range("A1:C1")
                End With

                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    'if SourceRange use all columns then skip this file
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0

                If Not sourceRange Is Nothing Then

                    SourceRcount = sourceRange.Rows.Count

                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "Sorry there are not enough rows in the sheet"
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else

                        'Copy the file name in column A
                        With sourceRange
                            BaseWks.Cells(rnum, "A"). _
                                    Resize(.Rows.Count).Value = FName(Fnum)
                        End With

                        'Set the destrange
                        Set destrange = BaseWks.Range("B" & rnum)

                        'we copy the values from the sourceRange to the destrange
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value

                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If

        Next Fnum
        BaseWks.Columns.AutoFit
    End If

ExitTheSub:
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
    ChDirNet SaveDriveDir
End Sub

Merge a range from all workbooks in a folder (next to each other)

This example will past the data next to each other. In column A you see the data from the first
workbook and in Column B the data from the next and in.....

There are a few things you must change before you can run the code

Fill in the path to the folder
MyPath = "C:\Users\Ron\test"

I use the first sheet of each workbook in my example (index 1)
Change the sheet index or fill in a sheet name: mybook.Worksheets("YourSheetName")
And change the range A1:A10 to your range.

Set sourceRange = mybook.Worksheets(1).Range("A1:A10")

Sub Basic_Example_3()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceCcount As Long, Fnum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim Cnum As Long, CalcMode As Long

    'Fill in the path\folder where the files are
    MyPath = "C:\Users\Ron\test"

    'Add a slash at the end if the user forget it
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    'If there are no Excel files in the folder exit the sub
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If

    'Fill the array(myFiles)with the list of Excel files in the folder
    Fnum = 0
    Do While FilesInPath <> ""
        Fnum = Fnum + 1
        ReDim Preserve MyFiles(1 To Fnum)
        MyFiles(Fnum) = FilesInPath
        FilesInPath = Dir()
    Loop

    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Add a new workbook with one sheet
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    Cnum = 1

    'Loop through all files in the array(myFiles)
    If Fnum > 0 Then
        For Fnum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
            On Error GoTo 0

            If Not mybook Is Nothing Then

                On Error Resume Next
                Set sourceRange = mybook.Worksheets(1).Range("A1:A10")

                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    'if SourceRange use all rows then skip this file
                    If sourceRange.Rows.Count >= BaseWks.Rows.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0

                If Not sourceRange Is Nothing Then

                    SourceCcount = sourceRange.Columns.Count

                    If Cnum + SourceCcount >= BaseWks.Columns.Count Then
                        MsgBox "Sorry there are not enough columns in the sheet"
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else

                        'Copy the file name in the first row
                        With sourceRange
                            BaseWks.cells(1, Cnum). _
                                    Resize(, .Columns.Count).Value = MyFiles(Fnum)
                        End With

                        'Set the destrange
                        Set destrange = BaseWks.cells(2, Cnum)

                        'we copy the values from the sourceRange to the destrange
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value

                        Cnum = Cnum + SourceCcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If

        Next Fnum
        BaseWks.Columns.AutoFit
    End If

ExitTheSub:
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With

End Sub

Merge a range from all workbooks in a folder with AutoFilter

This example will filter a range on a worksheet in every workbook in the folder and copy
the filter results to a new workbook.
There are five code lines that you must change before you run the code(see macro)

Note: the code use the function RDB_Last, copy this function also in your code module.
You find the function in the last section of this page.

Sub Basic_Example_4()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, FNum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long
    Dim rng As Range, SearchValue As String
    Dim FilterField As Integer, RangeAddress As String
    Dim ShName As Variant, RwCount As Long

    '**********************************************************
    '***Change this five code lines before you run the macro***
    '**********************************************************

    'Fill in the path\folder where the files are
    MyPath = "C:\Users\Ron\test"

    'Fill in the sheet name where the data is in each workbook
    'Use ShName = "Sheet1" if you want to use a sheet name instead if the index
    'We use the first sheet in every workbook in this example(I use the index)
    ShName = 1

    'Fill in the filter range: A1 is the header of the first column and G is
    'the last column in the range and it will filter on all rows on the sheet
    'You can also use a fixed range like A1:G2500 if you want
    RangeAddress = Range("A1:G" & Rows.Count).Address

    'Field that you want to filter in the range ( 1 = column A in this
    'example because the filter range start in column A
    FilterField = 1

    'Fill in the filter value ("<>ron" if you want the opposite)
    'Or use wildcards like "*ron" for cells that start with ron or use
    '"*ron*" if you look for cells where ron is a part of the cell value
    SearchValue = "ron"

    '**********************************************************
    '**********************************************************


    'Add a slash after MyPath if the user forget it
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    'If there are no Excel files in the folder exit the sub
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If

    'Fill the array(myFiles)with the list of Excel files in the folder
    FNum = 0
    Do While FilesInPath <> ""
        FNum = FNum + 1
        ReDim Preserve MyFiles(1 To FNum)
        MyFiles(FNum) = FilesInPath
        FilesInPath = Dir()
    Loop

    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Add a new workbook with one sheet
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    rnum = 1

    'Loop through all files in the array(myFiles)
    If FNum > 0 Then
        For FNum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
            On Error GoTo 0

            If Not mybook Is Nothing Then

                On Error Resume Next
                'set filter range
                With mybook.Worksheets(ShName)
                    Set sourceRange = .Range(RangeAddress)
                End With

                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                End If
                On Error GoTo 0

                If Not sourceRange Is Nothing Then
                    'Find the last row in BaseWks
                    rnum = RDB_Last(1, BaseWks.Cells) + 1

                    With sourceRange.Parent
                        Set rng = Nothing

                        'Firstly, remove the AutoFilter
                        .AutoFilterMode = False

                        'Filter the range on the FilterField column
                        sourceRange.AutoFilter Field:=FilterField, _
                                               Criteria1:=SearchValue

                        With .AutoFilter.Range

                            'Check if there are results after you use AutoFilter
                            RwCount = .Columns(1).Cells. _
                                      SpecialCells(xlCellTypeVisible).Cells.Count - 1

                            If RwCount = 0 Then
                                'There is no data, only the header
                            Else
                                ' Set a range without the Header row
                                Set rng = .Resize(.Rows.Count - 1, .Columns.Count). _
                                          Offset(1, 0).SpecialCells(xlCellTypeVisible)


                                'Copy the range and the file name in column A
                                If rnum + RwCount < BaseWks.Rows.Count Then
                                    BaseWks.Cells(rnum, "A").Resize(RwCount).Value _
                                          = mybook.Name
                                    rng.Copy BaseWks.Cells(rnum, "B")
                                End If
                            End If

                        End With

                        'Remove the AutoFilter
                        .AutoFilterMode = False

                    End With
                End If

                'Close the workbook without saving
                mybook.Close savechanges:=False
            End If

            'Open the next workbook
        Next FNum

        'Set the column width in the new workbook
        BaseWks.Columns.AutoFit
        MsgBox "Look at the merge results in the new workbook after you click on OK"
    End If

    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

RDB_Last function to find the last cell or row

Function RDB_Last(choice As Integer, rng As Range)
'Ron de Bruin, 5 May 2008
' 1 = last row
' 2 = last column
' 3 = last cell
    Dim lrw As Long
    Dim lcol As Integer

    Select Case choice

    Case 1:
        On Error Resume Next
        RDB_Last = rng.Find(What:="*", _
                            after:=rng.cells(1), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
        On Error GoTo 0

    Case 2:
        On Error Resume Next
        RDB_Last = rng.Find(What:="*", _
                            after:=rng.cells(1), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
        On Error GoTo 0

    Case 3:
        On Error Resume Next
        lrw = rng.Find(What:="*", _
                       after:=rng.cells(1), _
                       Lookat:=xlPart, _
                       LookIn:=xlFormulas, _
                       SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious, _
                       MatchCase:=False).Row
        On Error GoTo 0

        On Error Resume Next
        lcol = rng.Find(What:="*", _
                        after:=rng.cells(1), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
        On Error GoTo 0

        On Error Resume Next
        RDB_Last = rng.Parent.cells(lrw, lcol).Address(False, False)
        If Err.Number > 0 Then
            RDB_Last = rng.cells(1).Address(False, False)
            Err.Clear
        End If
        On Error GoTo 0

    End Select
End Function