After so many hours in that field, I could be able to get data from all the worksheets in closed workbook and could get data from specific columns using ADODB.
#Siddharth Rout helped me to be able to get the sheet names in the order of tab.
The following code works fine for only one closed workbook. But in fact I am trying to do the same and get all the data from the specific column (Reference - Ref No - Number ..) from several workbooks
Sub ImportFromClosedWorkbook()
Dim e, ws As Worksheet, cn As ADODB.Connection, rs As ADODB.Recordset, rsHeaders As ADODB.Recordset, b As Boolean, sFile As String, shName As String, strSQL As String, iCol As Long
sFile = ThisWorkbook.Path & "\Sample.xlsx"
Dim con As Object
Set con = CreateObject("DAO.DBEngine.120")
Dim rsData As ADODB.Recordset
Set cn = New ADODB.Connection
cn.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & sFile & "';" & "Extended Properties=""Excel 12.0;HDR=YES;IMEX=1;"";"
Set ws = ThisWorkbook.ActiveSheet
Dim db As Object, i As Long
Set db = con.OpenDatabase(sFile, False, True, "Excel 12.0 XMl;")
For i = 0 To db.TableDefs.Count - 1
sName = db.TableDefs(i).Name
b = False
strSQL = "SELECT * FROM [" & sName & "]"
Set rsHeaders = New ADODB.Recordset
rsHeaders.Open Source:=strSQL, ActiveConnection:=cn, Options:=1
For iCol = 0 To rsHeaders.Fields.Count - 1
For Each e In Array("Ref No", "Reference", "Number")
If e = rsHeaders.Fields(iCol).Name Then
b = True: Exit For
End If
Next e
If b Then Exit For
Next iCol
If b Then
strSQL = "SELECT [" & e & "] FROM [" & sName & "]"
Set rsData = New ADODB.Recordset
Set rsData = cn.Execute(strSQL)
ws.Range("A" & ws.Cells(Rows.Count, 1).End(xlUp).Row + 1).CopyFromRecordset rsData
rsData.Close
End If
Next i
db.Close: Set db = Nothing
Set con = Nothing
cn.Close: Set cn = Nothing
End Sub
Is it suitable to build a public procedure or what's the best approach in that case and how can I release the objects in correct way?
I would break out your code even more - there are distinct activities which could be factored out into reusable methods.
FYI your tableDefs objects already contains the field names, so there's no need to separately query for those.
Eg:
Sub ImportFromClosedWorkbook()
Dim sFile As String, sheetName As String, colName As String, rs As ADODB.Recordset
Dim cols As Collection, col
sFile = ThisWorkbook.FullName
Set cols = FindColumns(sFile, Array("Ref", "Reference", "RefNo"))
'loop found columns
For Each col In cols
sheetName = col(0)
colName = col(1)
Debug.Print "##", sheetName, colName
Set rs = WorkBookQuery(sFile, "Select [" & colName & "] from [" & sheetName & "]")
If Not rs.EOF Then
' ActiveSheet.Cells(Rows.Count, "A").End(xlUp).CopyFromRecordset rs
End If
Next col
End Sub
'given a workbook path, find all column headings matching andname in arrNames
'returns a collections of [sheetName, columnName] arrays
Function FindColumns(wbFullPath As String, arrNames) As Collection
Dim tabledefs As Object, td As Object, f As Object, rv As New Collection
Set tabledefs = CreateObject("DAO.DBEngine.120") _
.OpenDatabase(wbFullPath, False, True, "Excel 12.0 XMl;").tabledefs
For Each td In tabledefs
For Each f In td.Fields
'Debug.Print td.Name, f.Name
If Not IsError(Application.Match(f.Name, arrNames, 0)) Then
rv.Add Array(td.Name, f.Name)
End If
Next f
Next td
Set FindColumns = rv
End Function
'run a SQL query against a workbook
Function WorkBookQuery(wbFullPath As String, SQL As String) As ADODB.Recordset
Dim rs As ADODB.Recordset
With New ADODB.Connection
.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & wbFullPath & "';" & _
"Extended Properties=""Excel 12.0;HDR=YES;IMEX=1;"";"
Set WorkBookQuery = .Execute(SQL, Options:=1)
End With
End Function
There seems to be a logical error in the process of cycling through the fields. It would be nice to use a user-defined function that checks if the field name exists.
Sub ImportFromClosedWorkbook()
Dim e, ws As Worksheet, cn As ADODB.Connection, rs As ADODB.Recordset, rsHeaders As ADODB.Recordset, b As Boolean, sFile As String, shName As String, strSQL As String, iCol As Long
Dim sField As String
sFile = ThisWorkbook.Path & "\Sample.xlsx"
Dim con As Object
Set con = CreateObject("DAO.DBEngine.120")
Dim rsData As ADODB.Recordset
Set cn = New ADODB.Connection
cn.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & sFile & "';" & "Extended Properties=""Excel 12.0;HDR=YES;IMEX=1;"";"
Set ws = ThisWorkbook.ActiveSheet
Dim db As Object, i As Long
Set db = con.OpenDatabase(sFile, False, True, "Excel 12.0 XMl;")
For i = 0 To db.TableDefs.Count - 1
sName = db.TableDefs(i).Name
b = False
strSQL = "SELECT * FROM [" & sName & "]"
Set rsHeaders = New ADODB.Recordset
rsHeaders.Open Source:=strSQL, ActiveConnection:=cn, Options:=1
For iCol = 0 To rsHeaders.Fields.Count - 1
' For Each e In Array("Ref No", "Reference", "Number")
' If e = rsHeaders.Fields(iCol).Name Then
' b = True: Exit For
' End If
' Next e
' If b Then Exit For
' Next iCol
' If b Then
sField = rsHeaders.Fields(iCol).Name
If isField(sField) Then
strSQL = "SELECT [" & sField & "] FROM [" & sName & "]"
Set rsData = New ADODB.Recordset
Set rsData = cn.Execute(strSQL)
ws.Range("A" & ws.Cells(Rows.Count, 1).End(xlUp).Row + 1).CopyFromRecordset rsData
rsData.Close
End If
Next iCol
Next i
db.Close: Set db = Nothing
Set con = Nothing
cn.Close: Set cn = Nothing
End Sub
Function isField(sField As String) As Boolean
Dim vName As Variant, e As Variant
vName = Array("Ref No", "Reference", "Number")
For Each e In vName
If e = sField Then
isField = True
Exit Function
End If
Next e
End Function
If all the files have the same structure and are in a folder, you could use the FileSystemObject reference as below:
"https://stackoverflow.com/questions/10380312/loop-through-files-in-a-folder-using-vba"
and you could run the existing code in a loop in the file system code, hope that works
Related
I am trying to load data from an Excel file in a specific sheet into an ADODB.RecordSet via a VBA macro by using SQL SELECT command.
There are several columns on the Excel sheet, and I don't need all of them.
For example:
col.A = Surname, col.B = Name, col.C = IDPerson, [....columns that are not needed], Col.N = Boss
The purpose would be to get a recordset of aggregated data for:
col.C = IDPerson, col.N = Boss.
The fields highlighted in the image below.
I would like to have a RecordSet with the aggregated (non-repeating) data of the columns highlighted in yellow.
Obviously, this problem could also be solved by loading a matrix, but, in this case I would have to build a loading algorithm to "clean" any repetitions in the data and then later I would have to provide a search function with some loops.
So I thought that if I could load all the data I need by reading the WorkSheet as if it were a data table and then make a query on it to extract the data that I need and load everything in an ADODB.RecordSet would be much more efficient also for searching for data (filter data for example).
Below I report my code that loads all the data of my sheet:
Public Sub LoadRecordSet(ByVal LastRow As Long, ByVal LastCol As Integer)
Dim cnt As ADODB.Connection
Dim rsData As ADODB.Recordset
Dim strSQL As String
Dim strTMP As String
strTMP = Cells(LastRow, LastCol).Address
strTMP = Replace(strTMP, "$", "")
Set cnt = New ADODB.Connection
cnt.Mode = adModeRead
cnt.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ActiveWorkbook.FullName & ";" & _
"Extended Properties=""Excel 12.0 Macro;HDR=Yes;"";"
cnt.Open
strSQL = "SELECT * FROM [Sheet1$C2:" & strTMP & "]"
Set rsData = New ADODB.Recordset
With rsData
Set .ActiveConnection = cnt
.Source = strSQL
.CursorLocation = adUseClient
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Open
End With
'TODO - Something with rsData for filtering or to research
'GC
If Not rsData Is Nothing Then
If rsData.State <> adStateClosed Then rsData.Close
Set rsData = Nothing
End If
If Not cnt Is Nothing Then
If cnt.State <> adStateClosed Then cnt.Close
Set cnt = Nothing
End If
End Sub
My question is: "What if I just want to load some columns as described above and aggregate them so they don't have repetitions in the data?"
For example if I want to load similar
SELECT [cod.fiscale], responsabile FROM [MySheet$A3:N480] GROUP BY [cod.fiscale], responsabile
It's possible?
Thank you so much.
I improved my code which is now working:
Public Sub CaricaDati()
Dim cnt As ADODB.Connection
Dim rsDati As ADODB.Recordset
Dim strSQL As String
Dim strTMP As String
Dim i As Integer
on Error GoTo Error_Handler
Range("A3").Select
g_BOLTS_UltimaRiga = LasRow
Call LastCol
strTMP = Cells(g_LastRow, g_LastCol).Address
strTMP = Replace(strTMP, "$", "")
Set cnt = New ADODB.Connection
cnt.Mode = adModeRead
cnt.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ActiveWorkbook.FullName & ";" & _
"Extended Properties=""Excel 12.0 Macro;HDR=Yes;"";"
cnt.Open
'strSQL = "SELECT * FROM [2$C2:" & strTMP & "]"
strSQL = "SELECT cf, responsabile FROM [2$C2:" & strTMP & "] GROUP BY cf, responsabile"
Set rsDati = New ADODB.Recordset
With rsDati
Set .ActiveConnection = cnt
.Source = strSQL
.CursorLocation = adUseClient
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Open
End With
If Not (rsDati.BOF And rsDati.EOF) Then
strTMP = ""
For i = 0 To rsDati.Fields.Count - 1
strTMP = strTMP & rsDati.Fields(i).Name & ";"
Next i
Debug.Print strTMP
strTMP = ""
rsDati.MoveFirst
Do While Not rsDati.EOF
strTMP = ""
For i = 0 To rsDati.Fields.Count - 1
strTMP = strTMP & rsDati.Fields(i).Value & ";"
Next i
Debug.Print strTMP
rsDati.MoveNext
Loop
End If
Uscita:
On Error Resume Next
'GC
If Not rsDati Is Nothing Then
If rsDati.State <> adStateClosed Then rsDati.Close
Set rsDati = Nothing
End If
If Not cnt Is Nothing Then
If cnt.State <> adStateClosed Then cnt.Close
Set cnt = Nothing
End If
Exit Sub
Error_Handler:
On Error GoTo 0
MsgBox Err.Number & " - " & Err.Description, vbOKOnly + vbCritical, "ERRORE IMPREVISTO"
GoTo Uscita
End Sub
I have written a VBA code to update a column but getting Automation Error while running the program at line 41 which is Set rsf = cmd.Execute. Is the way of writing update statement incorrect in my code? Not getting what is the issue here. I'd appreciate any help towards a solution for my problem.
Private Sub Update_Visibility_Flag_Click()
Dim fldrpath As String
Dim currDate As String
Dim mePrgTrck As String
Dim wkb1 As Workbook
Dim sht1 As Worksheet
Dim cnf As ADODB.Connection
Dim rsf As ADODB.Recordset
Dim sqlstr As String
fldrpath = "\\lp99dfd\groups$\Record Extracts\New folder\New folder\" & Format(Date, "yyyymm")
currDate = "PI_202008"
mePrgTrck = fldrpath & "\LE\Progress_Tracker_" & Format(Date, "yyyymm") & "_LE.xlsx"
Set wkb1 = Workbooks.Open(mePrgTrck)
Set sht1 = wkb1.Sheets(currDate)
Set cnf = New ADODB.Connection
Set rsf = New ADODB.Recordset
cnf.Open ( _
"User ID=AI_ZK_DTA" & _
";Password=aizkdta" & _
";Data Source=POIUY" & _
";Provider=OraOLEDB.Oracle")
For Each cell In sht1.Range("A2:A28")
If cell.Offset(0, 3).Value = "Success" Then
sqlstr = "UPDATE AI_" & cell.Value & "_DTA SET VISIBLE = 'Y'"
Dim cmd As ADODB.Command
Set cmd = New ADODB.Command
Set cmd.ActiveConnection = cnf
cmd.CommandType = adCmdText
cmd.Properties("PLSQLRSet") = True
cmd.CommandText = sqlstr
Set rsf = cmd.Execute
cmd.Properties("PLSQLRSet") = False
cell.Offset(0, 8).Value = cell.Offset(0, 8).Value & "| Done"
End If
Next cell
wkb1.Close True
Set rsf = Nothing
Set cnf = Nothing
End Sub
Sub SavedConfiguration()
Dim cnn1 As New ADODB.Connection
Dim mrs As New ADODB.Recordset
Dim iCols As Integer
Const TABLE_NAME = "TableName"
Const DRIVER = "{SQL Server}"
Dim conf
conf = Array("D11", "database", "D12", "server")
Dim wb As Workbook, wsConfig As Worksheet, wsOut As Worksheet
Dim i As Integer, strConn As String, sQry As String
Set wb = ThisWorkbook
Set wsConfig = Worksheets("Settings")
Set wsOut = Worksheets("SavedConfig")
' construct connection string
strConn = "driver=" & DRIVER & ";"
For i = 1 To UBound(conf) Step 2
strConn = strConn & conf(i) & "=" & wsConfig.Range(conf(i - 1)).Value & ";"
Next
' Debug.Print strConn
sQry = Worksheets("SQL-COMMON").Range("B3").Value
' connect to db and run sql
Set cnnl = New ADODB.Connection
cnnl.ConnectionString = strConn
cnnl.ConnectionTimeout = 30
cnnl.Open
wsConfig.Range("H35") = Now
' output
mrs.Open sQry, cnn1
For iCols = 0 To mrs.Fields.Count - 1
wsOut.Cells(1, iCols + 1).Value = mrs.Fields(iCols).Name
Next
Worksheets("SavedConfig").Range("A2").CopyFromRecordset mrs
wsConfig.Range("D35") = Now
mrs.Close
cnn1.Close
End Sub
I have edited the code, am getting unspecified error while executing it
How to make the connection string more dynamic instead of hard coding above, and picking up the values from cells of the worksheet of excel.
How to add the code for showing the Last run start time and date and last run end time and date of the query which is being executed, getting tabulated automatically in the excel cells.
Build the connection string by concatenating each parameter.
Sub Conn2SQL()
Const TABLE_NAME = "TableName"
Const DRIVER = "{SQL Server}"
Dim conf
conf = Array("A12", "database", "A13", "server", _
"A14", "password", "A15", "uid")
Dim wb As Workbook, wsConfig As Worksheet, wsOut As Worksheet
Dim i As Integer, strConn As String, sQry As String
Set wb = ThisWorkbook
Set wsConfig = wb.Sheets("Sheet1")
Set wsOut = wb.Sheets("SavedConfig")
' construct connection string
strConn = "driver=" & DRIVER & ";"
For i = 1 To UBound(conf) Step 2
strConn = strConn & conf(i) & "=" & wsConfig.Range(conf(i - 1)).Value & ";"
Next
'Debug.Print strConn
sQry = "SELECT * FROM [" & TABLE_NAME & "]"
' connect to db and run sql
Dim cnn1 As New ADODB.Connection, mrs As New ADODB.Recordset
Dim iCols As Integer
With cnn1
.ConnectionString = strConn
.ConnectionTimeout = 30
.Open
End With
wsConfig.Range("H35") = "LAST RUN STARTED " & Now
cnn1.Execute "USE " & wsConfig.Range(conf(0))
' output
mrs.Open sQry, cnn1
For iCols = 0 To mrs.Fields.Count - 1
wsOut.Cells(1, iCols + 1).Value = mrs.Fields(iCols).Name
Next
wsOut.Cells(2, 1).CopyFromRecordset mrs 'A2
wsConfig.Range("D35") = "LAST RUN COMPLETED " & Now
i = wsOut.Cells(Rows.Count, 1).End(xlUp).Row
MsgBox i & " rows added to " & wsOut.Name, vbInformation
mrs.Close
cnn1.Close
End Sub
Test the connection string with this code
Sub testconnect()
Dim conn As New ADODB.Connection, rs As New ADODB.Recordset, s As String
s = "" ' put connection string here
With conn
.ConnectionString = s
.ConnectionTimeout = 30
.Open
End With
Set rs = conn.Execute("SELECT CURRENT_TIMESTAMP")
MsgBox "Time is " & rs(0), vbOKOnly
conn.Close
End Sub
using vba macro I used the below query and I can able to get the results
strsQL = "SELECT name,address, balance1,balance2,balance3 FROM userInfo.csv"
if there any possibility to get the sql results using column index , instead of using column name (address) in VBA macro
Try it this way.
Sub GetMyCSVData()
Dim xlcon As ADODB.Connection
Dim xlrs As ADODB.Recordset
Set xlcon = New ADODB.Connection
Set xlrs = New ADODB.Recordset
Dim currentDataFilePath As String
Dim currentDataFileName As String
Dim nextRow As Integer
currentDataFilePath = "C:\My Data Folder\"
currentDataFileName = "My Data File"
xlcon.Provider = "Microsoft.Jet.OLEDB.4.0"
xlcon.ConnectionString = "Data Source=" & currentDataFilePath & ";" & "Extended Properties=""text;HDR=Yes;FMT=Delimited;"""
xlcon.Open
xlrs.Open "SELECT FirstName, Surname, Age FROM [" & currentDataFileName & ".csv] WHERE SomeNumber > 10", xlcon
xlrs.MoveFirst
nextRow = Worksheets("Sheet1").UsedRange.Rows.Count + 1
Worksheets("Sheet1").Cells(nextRow, 1).CopyFromRecordset xlrs
xlrs.Close
xlcon.Close
Set xlrs = Nothing
Set xlcon = Nothing
End Sub
I'm having problems to specify a value to start adding fields to my table, i need to insert all the values with the condition of this specific value in the MOD_CODE column from Excel to be inserted in this way to Access.
.Fields("MOD_CODE") = Sheets(wsName).Cells(iX, 2).Value
It inserts all the fields correctly from Excel to Access but i can not make that picks a specific value in this field
Dim Conn As ADODB.Connection, RecSet As ADODB.Recordset
Dim fila As Long, primerFila As Integer, ultimaFila As Long, iX As Long
Dim dataSource As String, Tabla As String
Dim wsName As String
Dim rFound As Range
dataSource = Sheets("parametros").[B1]
Tabla = Sheets("parametros").[B2]
wsName = Sheets("parametros").[B3]
primerFila = Sheets("parametros").[B4]
Set Conn = New ADODB.Connection
Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source= " & dataSource & ";"
'Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & dataSource & ";"
Set RecSet = New ADODB.Recordset
RecSet.Open Tabla, Conn, adOpenKeyset, adLockOptimistic, adCmdTable
ultimaFila = WorksheetFunction.CountA(Sheets(wsName).Range("A:A"))
For iX = primerFila To ultimaFila
With RecSet
.AddNew
.Fields("PLANT") = Sheets(wsName).Cells(iX, 1).Value
.Fields("MOD_CODE") = Sheets(wsName).Cells(iX, 2).Value
.Fields("BOM_KEY") = Sheets(wsName).Cells(iX, 3).Value
.Fields("ASSY_ADDRESS") = Sheets(wsName).Cells(iX, 4).Value
.Update
End With
Next iX
RecSet.Close
Set RecSet = Nothing
Conn.Close
Set Conn = Nothing
End Sub