Reading Data using OLEDB from opened Excel File - excel

I have an excel file(Lets' say File X) with 2 sheets. In first sheet I display charts. Second I have data for the chart. In order to get data from chart, I need to process that data as we do in SQL like Group by, order by. Is there any way I can use oledb to read data from second sheet using VBA code in same excel file(file X)?
Thanks!!

Here's an example of using SQL to join data from two ranges: it will work fine if the file is open (as long as it has been saved, because you need a file path).
Sub SqlJoin()
Dim oConn As New ADODB.Connection
Dim oRS As New ADODB.Recordset
Dim sPath
Dim sSQL As String
sSQL = "select a.blah from <t1> a, <t2> b where a.blah = b.blah"
sSQL = Replace(sSQL, "<t1>", Rangename(Sheet1.Range("A1:A5")))
sSQL = Replace(sSQL, "<t2>", Rangename(Sheet1.Range("C1:C3")))
If ActiveWorkbook.Path <> "" Then
sPath = ActiveWorkbook.FullName
Else
MsgBox "Workbook being queried must be saved first..."
Exit Sub
End If
oConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & sPath & "';" & _
"Extended Properties='Excel 12.0;HDR=Yes;IMEX=1';"
oRS.Open sSQL, oConn
If Not oRS.EOF Then
Sheet1.Range("E1").CopyFromRecordset oRS
Else
MsgBox "No records found"
End If
oRS.Close
oConn.Close
End Sub
Function Rangename(r As Range) As String
Rangename = "[" & r.Parent.Name & "$" & _
r.Address(False, False) & "]"
End Function

Related

Connectionstring vba with blank space in dataname get broken

My Code is following. I'll try to copy a range of data from a closed sheet with connectionstrings. The Code is okay if the dataname hasn't a empty string.
e.g. test.xlsx is okay but test further.xlsx get broken.
'using sql
Sub ImportThisFile(FilePath As String, SourceSheet As String, Destination As Range)
Set Conn = New ADODB.Connection
'xls
'Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & _
' FilePath & ";Extended Properties=Excel 8.0;"
'xlsx
Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & _
FilePath & ";Extended Properties=Excel 12.0 Xml;"
Sql = "SELECT * FROM [" & SourceSheet & "$] WHERE [fieldname] <> " & [""""""]
Set RcdSet = New ADODB.Recordset
RcdSet.Open Sql, Conn, adOpenForwardOnly
Destination.CopyFromRecordset RcdSet
RcdSet.Close
Set RcdSet = Nothing
Conn.Close
Set Conn = Nothing
End Sub
Sub StartDoingStuff()
Dim Zeit As Long, Anzahl As Long
Anzahl = 1
Zeit = Timer
Dim testvar As String, testvar2 As String, testvar3 As String
testvar = "C:\Users\Admin\Desktop\Folder\"
testvar2 = "testdata with emptystrings.xlsx.xlsx"
testvar2 = "test.xlsx"
testvar3 = "Tabelle1"
ImportThisFile testvar & testvar2, "Timesheet", Range(testvar3 & "!A2")
Debug.Print "Zeitbedarf"; Round(Timer - Zeit, 3)
End Sub
And Second Question.
If I want to copy a range, how i must write the code?
I need to determine the last cell in a column. How is that possible ?
the code i posted is correct. It was a mistake in the workbook (tablename)

Use ADODB to INSERT INTO specific table in an Excel workbook

I'm trying to use ADODB to execute a SQL INSERT INTO command into an Excel worksheet. I was able to insert into the worksheet when there was only one column in the worksheet using this code:
Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adCmdText = &H1
Dim Connection As ADODB.Connection
Set Connection = New ADODB.Connection
Connection.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data
Source=PathToFile.xls;Extended
Properties=Excel 8.0;"
Connection.Open
Dim SQL As String
SQL = "INSERT INTO [Sheet1$] VALUES('Test')"
Call Connection.Execute(SQL, , CommandTypeEnum.adCmdText Or ExecuteOptionEnum.adExecuteNoRecords)
But I want to have three separate tables in the same worksheet and specify which of the tables to insert into. How can I do this? I tried creating the tables, naming them, and using this SQL statement to specify a table but I kept getting the error: The Microsoft Jet database engine could not find the object 'TestTable1'. Make sure the object exists and that you spell its name and the path name correctly.
SQL = "INSERT INTO TestTable1(ID) VALUES('test')"
You can do something like this:
Sub TestInsert()
InsertRecords Sheet4.Range("B3").CurrentRegion, _
"insert into # values('AAA','BBB','CCC')"
InsertRecords Sheet4.Range("F3").CurrentRegion, _
"insert into # values('ZZZ')"
InsertRecords Sheet4.Range("H3").CurrentRegion, _
"insert into # values('Whirled',99999)"
End Sub
Sub InsertRecords(rng As Range, sSQL As String)
Const S_TEMP_TABLENAME As String = "SQLtempTable"
Dim oConn As New ADODB.Connection
Dim sPath
'name the selected range
On Error Resume Next
ThisWorkbook.Names.Item(S_TEMP_TABLENAME).Delete
If Err.Number <> 0 Then Err.Clear
On Error GoTo haveError
ThisWorkbook.Names.Add Name:=S_TEMP_TABLENAME, RefersToLocal:=rng
sPath = ThisWorkbook.Path & "\" & ThisWorkbook.Name
oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & sPath & _
";Extended Properties=""Excel 8.0;HDR=Yes"""
oConn.Execute Replace(sSQL, "#", S_TEMP_TABLENAME)
Exit Sub
haveError:
MsgBox Err.Description
End Sub
Before:
After:

Importing Excel worksheet range to Ms Access Table

Good Afternoon,
I have created a Macro that uploads data to a access database ( both on my desktop). The problem is it I keep getting errors when I try to expand the range.
I presumed it would be something simple but seems to be something I am overlooking.
here is the code - basically I would like to include the column or set it to a dynamic range? can you please help?
Sub AccessCode()
Application.ScreenUpdating = False
Dim db As Database
Dim rs As DAO.Recordset
Set db = OpenDatabase("C:\Users\user\Desktop\Test Copy.accdb")
Set rs = db.OpenRecordset("Fact Table", dbOpenTable)
rs.AddNew
rs.Fields("GUID") = Range("g2").Value
rs.Fields("StageID") = Range("h2").Value
rs.Fields("Sync Date") = Range("i2").Value
rs.Fields("Forecast HP") = Range("j2").Value
rs.Fields("Owner Id") = Range("k2").Value
rs.Fields("Recent Modified Flag") = Range("L2").Value
rs.Fields("Upload Date") = Range("M2").Value
rs.Update
rs.Close
db.Close
Application.ScreenUpdating = True
MsgBox " Upload To PMO Database Successful."
End Sub
You can use a query instead of iterating through a recordset:
Sub AccessCode()
Application.ScreenUpdating = False
Dim db As Database
Dim rs As DAO.Recordset
Set db = OpenDatabase("C:\Users\user\Desktop\Test Copy.accdb")
db.Execute "INSERT INTO [Fact Table] ([GUID], [StageID], etc) " & _
"SELECT * FROM [SheetName$G:M] " & _
"IN """ & ActiveWorkbook.FullName & """'Excel 12.0 Macro;HDR=No;'"
End Sub
This has numerous advantages, such as often being faster because you don't have to iterate through all the fields.
If you would trigger the import from Access instead of Excel, you wouldn't even need VBA to execute the query.
Change the rs section to this one:
With rs
.addnew
!GUID = Range("g2").Value
!StageID = Range("h2").Value
'...etc
.Update
End With
MSDN source
Use the AddNew method to create and add a new record in the Recordset object named by recordset. This method sets the fields to default values, and if no default values are specified, it sets the fields to Null (the default values specified for a table-type Recordset).
After you modify the new record, use the Update method to save the changes and add the record to the Recordset. No changes occur in the database until you use the Update method.
Edit:
This is how your code should look like, when you change the rs section with the code above:
Sub AccessCode()
Application.ScreenUpdating = False
Dim db As Database
Dim rs As DAO.Recordset
Set db = OpenDatabase("C:\Users\user\Desktop\Test Copy.accdb")
Set rs = db.OpenRecordset("Fact Table", dbOpenTable)
With rs
.addnew
!GUID = Range("g2").Value
!StageID = Range("h2").Value
'...etc
.Update
.Close
End With
Application.ScreenUpdating = True
MsgBox " Upload To PMO Database Successful."
End Sub
Just thought I'd add in an alternative to #Erik von Asmuth's excellent answer. I use something like this in a real project. It's a little more robust for importing a dynamic range.
Public Sub ImportFromWorksheet(sht As Worksheet)
Dim strFile As String, strCon As String
strFile = sht.Parent.FullName
strCon = "Excel 12.0;HDR=Yes;Database=" & strFile
Dim strSql As String, sqlTransferFromExcel As String
Dim row As Long
row = sht.Range("A3").End(xlDown).row
Dim rng As Range
sqlTransferFromExcel = " Insert into YourTable( " & _
" [GUID] " & _
" ,StageID " & _
" ,[sync Date] " & _
" ,[etc...] " & _
" ) " & _
" SELECT [GUID] " & _
" ,StageID " & _
" ,[sync Date] " & _
" ,[etc...] " & _
" FROM [{{connString}}].[{{sheetName}}$G2:M{{lastRow}}]"
sqlTransferFromExcel = Replace(sqlTransferFromExcel, "{{lastRow}}", row)
sqlTransferFromExcel = Replace(sqlTransferFromExcel, "{{connString}}", strCon)
sqlTransferFromExcel = Replace(sqlTransferFromExcel, "{{sheetName}}", sht.Name)
CurrentDb.Execute sqlTransferFromExcel
End Sub

combining multiple workbooks into one worksheet

I am currently trying to get data recorded into excel workbooks to be automatically copied over onto one "mass data" sheet. The files are named by date ex. "5-28-17". There is one for each day of the month. I'd like to collect all data into one sheet, as previously stated, in order by date descending.
I am currently using this code which should place all of the different workbooks onto their own worksheet, but I am having issues with that as well.
Option Explicit
Const path As String = "C:\Users\dt\Desktop\dt kte\"
Sub GetSheets()
Dim FileName As String
Dim wb As Workbook
Dim sheet As Worksheet
FileName = Dir(path & "*.xls*")
Do While FileName <> ""
Set wb = Workbooks.Open(FileName:=path & FileName, ReadOnly:=True)
For Each sheet In wb.Sheets
sheet.Copy After:=ThisWorkbook.Sheets(1)
Next sheet
wb.Close
FileName = Dir()
Loop
End Sub
I am trying to do this with VBA. There are 15 columns in the sheets I'm pulling from and the sheet I want to copy to. All line up perfectly. Is there a way to move the sheets from the WB I'm currently working on which should contain a worksheet for each WB onto one mass worksheet? Or can I pull all data directly from the folder with all of the workbooks saved by date to one worksheet?
I would use this AddIn.
https://www.rondebruin.nl/win/addins/rdbmerge.htm
It will do what you want, and a whole lot more as well.
Consider using an MS Access database. Not to worry if you do not have the Office GUI .exe app installed. Because you use a Windows machine, you do have its Jet/ACE SQL Engine (.dll files).
CREATE DATABASE
Sub CreateDatabase()
On Error GoTo ErrHandle
Dim fso As Object, olDb As Object, db As Object
Const dbLangGeneral = ";LANGID=0x0409;CP=1252;COUNTRY=0"
Const strpath As String = "C:\Path\To\ExcelDatabase.accdb"
' CREATE DATABASE
Set fso = CreateObject("Scripting.FileSystemObject")
Set olDb = CreateObject("DAO.DBEngine.120")
If Not fso.FileExists(strpath) Then
Set db = olDb.CreateDatabase(strpath, dbLangGeneral)
End If
MsgBox "Successfully created database!", vbInformation
ExitSub:
Set db = Nothing: Set olDb = Nothing: Set fso = Nothing
Exit Sub
ErrHandle:
MsgBox Err.Number & " - " & Err.Description, vbCritical, "RUNTIME ERROR"
Resume ExitSub
End Sub
CREATE, POPULATE, EXPORT EXCEL TABLE (Excel files never opened)
Sub CreateTable()
On Error GoTo ErrHandle
Dim conn As Object, rst As Object
Dim constr As String, FileName As String, i As Integer
Const xlpath As String = "C:\Users\dt\Desktop\dt kte\"
Const accpath As String = "C:\Path\To\ExcelDatabase.accdb"
' CONNECT TO DATABASE
constr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & accpath & ";"
Set conn = CreateObject("ADODB.Connection")
conn.Open constr
i = 1
FileName = Dir(xlpath & "*.xls*")
Do While FileName <> ""
If i = 1 Then
' CREATE TABLE VIA MAKE TABLE QUERY
conn.Execute "SELECT * INTO MyExcelTable" _
& " FROM [Excel 12.0 Xml;HDR=Yes;" _
& " Database=" & xlpath & FileName & "].[Sheet1$]"
Else
' POPULATE VIA APPEND QUERY
conn.Execute "INSERT INTO MyExcelTable" _
& " SELECT * FROM [Excel 12.0 Xml;HDR=Yes;" _
& " Database=" & xlpath & FileName & "].[Sheet1$]"
End If
i = i + 1
FileName = Dir()
Loop
' EXPORT TO EXCEL
Set rst = CreateObject("ADODB.Recordset")
rst.Open "SELECT * FROM MyExcelTable", conn
ThisWorkbook.Worksheets("MASS_DATA").Range("A1").CopyFromRecordset rst
' CLOSE CONNECTION
rst.Close: conn.Close
MsgBox "Successfully created and populated table!", vbInformation
ExitSub:
Set rst = Nothing: Set conn = Nothing
Exit Sub
ErrHandle:
MsgBox Err.Number & " - " & Err.Description, vbCritical, "RUNTIME ERROR"
Resume ExitSub
End Sub

Using 'Insert Into' SQL Statement with column names on Excel Worksheet with ACE OLEDB fails

So, I want to get disciplined in how I store data to worksheets and was wanting to use the SQL OLEDB Provide for Excel and standard SQL statements. Insert into with column names does not work, yet, for me at least. Some code demonstrates the problem. Expecting both forms shown here to work W3 Schools SQL INSERT INTO Statement
Option Explicit
Sub MinimalCompleteVerifiableExample()
'Tools->References "Microsoft ActiveX Data Objects 2.8 Library"
Dim wsNew As Excel.Worksheet
Set wsNew = ThisWorkbook.Worksheets.Add
wsNew.Cells(1, 1) = "TimeStamp"
wsNew.Cells(1, 2) = "Path"
Dim oConn As ADODB.Connection
Set oConn = New ADODB.Connection
Debug.Assert UBound(Split(ThisWorkbook.Name, ".")) > 0 '* Workbook needs to be saved
oConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties='Excel 12.0 Macro'"
Dim rsTestRead As ADODB.Recordset
Set rsTestRead = New ADODB.Recordset
rsTestRead.Open "Select * from [" & wsNew.Name & "$] AS P", oConn, adOpenStatic
Debug.Assert oConn.Errors.Count = 0
Debug.Assert rsTestRead.Fields.Item(0).Name = "TimeStamp"
Debug.Assert rsTestRead.Fields.Item(1).Name = "Path"
Dim sSQL As String
sSQL = "insert into [" & wsNew.Name & "$] (TimeStamp,Path) VALUES ('31-Dec-2015','C:\temp');" 'DOES NOT WORK
'sSQL = "insert into [" & wsNew.Name & "$] values ('25-Dec-2015','C:\temp')" 'works
Stop
oConn.Execute sSQL
Debug.Assert oConn.Errors.Count = 0
Stop
End Sub
On gets an error message of "Syntax error in INSERT INTO statement."
Ah.
It seems one adds square brackets around the column names
Dim sSQL As String
sSQL = "insert into [" & wsNew.Name & "$] ([TimeStamp],[Path]) VALUES ('31-Dec-2015','C:\temp');"

Resources