' <<<<<<<<<<<<<<<<<<<<<<<<<<< EXCEL SQL TOOL KIT >>>>>>>>>>>>>>>>>>>>>>>>>>>
' | |
' | Created by: Irish_Griffin and those at MrExcel.com |
' | Date: Jan 10, 2010 |
' | Version: 1.1 |
' | |
' | This file allows intermediate users to preform SQL |
' | functions from Excel using the "ADO" 2.8 API |
' | For a tutorial in SQL, visit the following site: |
' | http://www.w3schools.com/SQl/default.asp |
' | |
' | Here is the list of tools: |
' | -> CREATE A DATABASE |
' | -> DELETE A DATABASE |
' | -> CREATE A TABLE IN THE DB FROM A RANGE |
' | -> CREATE A TABLE IN THE DB FROM AN ARRAY |
' | -> DELETE A TABLE IN THE DB |
' | -> PREFORM SQL CODE TO GENERATE ARRAY WITH OUT TITLES |
' | -> PREFORM SQL CODE TO GENERATE ARRAY WITH TITLES |
' | -> PREFORM SQL CODE AND PASTE INTO RANGE |
' | |
' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'IMPORTANT --> To change database server, you must modify ALL "Connection_String" in below code
' For details see -> www.w3schools.com/ado/ado_connect.asp & www.connectionstrings.com
Sub Create_DB(DB_Location_Name As String)
' This function can create either a local or network .mdb file for temporary or permenant use
Dim ADO_Catalog As ADOX.Catalog
Dim Connection_String As String
Connection_String = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DB_Location_Name & ";"
Set ADO_Catalog = New ADOX.Catalog
'Automaticly will delete previous file if present
On Error Resume Next
Kill DB_Location_Name
On Error GoTo 0
ADO_Catalog.Create (Connection_String)
End Sub
Sub Delete_DB(DB_Location_Name As String)
'This function can delete a .mdb file
On Error Resume Next
Kill DB_Location_Name
On Error GoTo 0
End Sub
Sub Range_to_DB_Table(DB_Location_Name As String, New_Table_Name As String, Data_Range As Range)
'This function takes a sheet and pastes it into a created database
'Opens a connection to the database File
Dim Connection_String As String
Connection_String = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DB_Location_Name & ";"
Dim ADO_Connection As ADODB.connection
Set ADO_Connection = New ADODB.connection
ADO_Connection.Open (Connection_String)
Dim Column_Title As String
Dim column_count As Integer
Dim SQL_Text As String
Dim i As Integer
Dim r As Integer
Dim c As Integer
Dim box As Range ' Pklace holder to scan through the original range
Dim Colan As String
'delte table with same name if it exisits
SQL_Text = "DROP TABLE " & New_Table_Name
On Error Resume Next
ADO_Connection.Execute SQL_Text
On Error GoTo 0
column_count = Data_Range.Columns.Count
SQL_Text = "CREATE TABLE " & New_Table_Name & " ("
'This tool assumes text..... will improve later
'Place the titles into an array
c = Data_Range.Column
For i = 0 To column_count - 1
Column_Title = Data_Range.Cells(1, i + 1).Value
'Check to see column titles meet criteria : No spaces and required text
If Trim(Column_Title) = "" Then
MsgBox ("Data Range has blank column titles. Fix to execute the code.")
MsgBox (SQL_Text)
GoTo The_End
End If
If Not InStr(1, Column_Title, " ") = 0 Then
MsgBox ("One of the column titles has a space. Fix to execute the code.")
MsgBox (SQL_Text)
'GoTo The_End
End If
SQL_Text = SQL_Text & "[" & Column_Title & "] Text(150) WITH Compression, "
Next
SQL_Text = Left(SQL_Text, Len(SQL_Text) - 2) & ")"
ADO_Connection.Execute SQL_Text
'Data upload into table
SQL_Text = "INSERT INTO " & New_Table_Name & " VALUES("
'Knowing that the first row contain titles we add 1 to the row
r = Data_Range.Row
First_Row = r
r = r + 1
Colan = """"
'For loop starts at the top left, crosses over to the right, drops a row and repeats
For Each box In Data_Range
'If statement placed to skip first row that contians titles
If First_Row < box.Row Then
'Checks to see if a new row has started , thus the database needs the latest record uploaded
If r <> box.Row Then
'Triggered when the box value moves down a row , thus needing a record upload to the table
If r > 1 Then
SQL_Text = Left(SQL_Text, Len(SQL_Text) - 1)
SQL_Text = SQL_Text & ")"
ADO_Connection.Execute SQL_Text
End If
r = box.Row
'Resets the initial SQL text string to upload new re
SQL_Text = "INSERT INTO " & New_Table_Name & " VALUES("
End If
'Updates the SQL text
SQL_Text = SQL_Text & Colan & box.Value & Colan & ","
End If
Next
The_End:
'Close the connection so that computer resources are not used
ADO_Connection.Close
Set ADO_Connection = Nothing
End Sub
Sub Delete_DB_Table(DB_Location_Name As String, Table_Name As String)
'Opens a connection to the database File
Dim ADO_Connection As ADODB.connection
Set ADO_Connection = New ADODB.connection
Connection_String = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DB_Location_Name & ";"
ADO_Connection.Open (Connection_String)
Dim SQL_Text As String
SQL_Text = "DROP TABLE " & Table_Name
On Error Resume Next
ADO_Connection.Execute SQL_Text
On Error GoTo 0
'Close the connection so that computer resources are not used
ADO_Connection.Close
Set ADO_Connection = Nothing
End Sub
Function SQL_to_Array_wo_Titles(DB_Location_Name As String, SQL_Text As String) As Variant
' This code will run SQL on an existing table and results will be outputed to a new db table
'Opens a connection to the database File
Dim ADO_Connection As ADODB.connection
Set ADO_Connection = New ADODB.connection
Connection_String = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DB_Location_Name & ";"
ADO_Connection.Open (Connection_String)
Dim CMD As New ADODB.Command
Dim RS As ADODB.Recordset
CMD.ActiveConnection = ADO_Connection
CMD.CommandType = adCmdText
CMD.CommandText = SQL_Text
Set RS = CMD.Execute
'Create the Array
SQL_to_Array_wo_Titles = RS.GetRows()
'Clean up recordset object
RS.Close
Set RS = Nothing
'Close the connection so that computer resources are not used
ADO_Connection.Close
Set ADO_Connection = Nothing
End Function
Function SQL_to_Array_w_Titles(DB_Location_Name As String, SQL_Text As String) As Variant
' This code will run SQL on an existing table and results will be outputed to a new db table
'Opens a connection to the database File
Dim ADO_Connection As ADODB.connection
Set ADO_Connection = New ADODB.connection
Connection_String = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DB_Location_Name & ";"
ADO_Connection.Open (Connection_String)
Dim CMD As New ADODB.Command
Dim RS As ADODB.Recordset
Dim Row_Count As Long
Dim Col_Count As Long
CMD.ActiveConnection = ADO_Connection
CMD.CommandType = adCmdText
CMD.CommandText = SQL_Text
Set RS = CMD.Execute
Col_Count = RS.Fields.Count
Row_Count = 0
RS.MoveFirst
Do While Not RS.EOF
Row_Count = Row_Count + 1
RS.MoveNext
Loop
ReDim My_Array(0 To Col_Count - 1, 0 To Row_Count) As Variant '1 not subtracted from row_count to allow room for titles
Dim r As Integer
Dim c As Integer
'Place titles on array
For c = 0 To Col_Count - 1
On Error Resume Next
My_Array(c, 0) = RS.Fields(c).Name
On Error GoTo 0
Next
'copys data from recordset into array
r = 0
RS.MoveFirst
Do While Not RS.EOF
r = r + 1
For c = 0 To Col_Count - 1
My_Array(c, r) = RS.Fields(c).Value
Next
RS.MoveNext
Loop
SQL_to_Array_w_Titles = My_Array
'Clean up recordset object
RS.Close
Set RS = Nothing
'Close the connection so that computer resources are not used
ADO_Connection.Close
Set ADO_Connection = Nothing
End Function
Sub SQL_to_Range(DB_Location_Name As String, SQL_Text As String, Target_Range As Range, With_Titles As Boolean)
' This code will run SQL on an existing table and results will be outputed to a new db table
'Opens a connection to the database File
Dim ADO_Connection As ADODB.connection
Set ADO_Connection = New ADODB.connection
Connection_String = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DB_Location_Name & ";"
ADO_Connection.Open (Connection_String)
Dim CMD As New ADODB.Command
Dim RS As ADODB.Recordset
CMD.ActiveConnection = ADO_Connection
CMD.CommandType = adCmdText
CMD.CommandText = SQL_Text
Set RS = CMD.Execute
Call RS2WS(RS, Target_Range, With_Titles)
'Clean up recordset object
RS.Close
Set RS = Nothing
'Close the connection so that computer resources are not used
ADO_Connection.Close
Set ADO_Connection = Nothing
End Sub
Sub RS2WS(RS As ADODB.Recordset, TargetCell As Range, With_Titles As Boolean)
Dim f As Integer, r As Long, c As Long
If RS Is Nothing Then Exit Sub
If RS.State <> adStateOpen Then Exit Sub
If TargetCell Is Nothing Then Exit Sub
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.StatusBar = "Writing data from recordset..."
End With
With TargetCell.Cells(1, 1)
r = .Row
c = .Column
End With
With TargetCell.Parent
.Range(.Cells(r, c), .Cells(.Rows.Count, c + RS.Fields.Count - 1)).Clear
' clear existing contents
' write column headers
If With_Titles = True Then
For f = 0 To RS.Fields.Count - 1
On Error Resume Next
.Cells(r, c + f).Formula = RS.Fields(f).Name
On Error GoTo 0
Next f
Else
r = r - 1
End If
' write records
On Error Resume Next
RS.MoveFirst
On Error GoTo 0
Do While Not RS.EOF
r = r + 1
For f = 0 To RS.Fields.Count - 1
On Error Resume Next
.Cells(r, c + f).Formula = RS.Fields(f).Value
On Error GoTo 0
Next f
RS.MoveNext
Loop
.Rows(TargetCell.Cells(1, 1).Row).Font.Bold = True
.Columns("A:IV").AutoFit
End With
With Application
.StatusBar = False
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Sub Array_to_DB_table(DB_Location_Name As String, New_Table_Name As String, Data_Array As Variant)
'Opens a connection to the database File
Dim Connection_String As String
Connection_String = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DB_Location_Name & ";"
Dim ADO_Connection As ADODB.connection
Set ADO_Connection = New ADODB.connection
ADO_Connection.Open (Connection_String)
Dim Column_Title As String
Dim SQL_Text As String
Dim i As Integer
Dim r As Integer
Dim c As Integer
Dim Colan As String
Dim Array_LB As Integer
Dim Array_UB As Integer
Dim Record_LB As Long
Dim Record_UB As Long
'delte table with same name if it exisits
SQL_Text = "DROP TABLE " & New_Table_Name
On Error Resume Next
ADO_Connection.Execute SQL_Text
On Error GoTo 0
Array_UB = UBound(Data_Array)
Array_LB = LBound(Data_Array)
Record_UB = UBound(Data_Array, 2)
Record_LB = LBound(Data_Array, 2)
SQL_Text = "CREATE TABLE " & New_Table_Name & " ("
'This tool assumes text..... will improve later
'Place the titles into an array
For i = Array_LB To Array_UB
Column_Title = Data_Array(i, Record_LB)
'Check to see column titles meet criteria : No spaces and required text
If Trim(Column_Title) = "" Then
MsgBox ("Data Range has blank column titles. Fix to execute the code.")
GoTo The_End
End If
If Not InStr(1, Column_Title, " ") = 0 Then
MsgBox ("One of the column titles has a space. Fix to execute the code.")
GoTo The_End
End If
SQL_Text = SQL_Text & "[" & Column_Title & "] Text(150) WITH Compression, "
Next
SQL_Text = Left(SQL_Text, Len(SQL_Text) - 2) & ")"
ADO_Connection.Execute SQL_Text
Colan = """"
'Loop through the Array record sets and paste into the table
For r = Record_LB + 1 To Record_UB
SQL_Text = "INSERT INTO " & New_Table_Name & " VALUES("
For c = Array_LB To Array_UB
SQL_Text = SQL_Text & Colan & Data_Array(c, r) & Colan & ","
Next
SQL_Text = Left(SQL_Text, Len(SQL_Text) - 1)
SQL_Text = SQL_Text & ")"
ADO_Connection.Execute SQL_Text
Next
The_End:
'Close the connection so that computer resources are not used
ADO_Connection.Close
Set ADO_Connection = Nothing
End Sub
.... Instead, lets talk about BEST PRACTICES using SQL in EXCEL 
