This is the code that I use to upload file into database using VBA, but this loop can only run once. During the second loop it will give error, the error is
Operation is not allowed in this context
Can anybody suggest me what to do?
The error is in the line adoStream.Type = adTypeBinary
Dim stCon As String 'SQL Connection string
Dim stProcName As String 'Stored Procedure name
Dim strCmd As String
Dim adoStream As Object
Dim adocmd As Object
Dim strFilePath As String
Dim adoCon As Object
Set adoCon = CreateObject("ADODB.Connection")
Set adoStream = CreateObject("ADODB.Stream")
Set adocmd = CreateObject("ADODB.Command")
adoCon.CursorLocation = adUseClient
adoCon.Open "Provider=SQLOLEDB; " & _
"Data Source=#########; " & _
"Initial Catalog=#######;" & _
"User ID=#######; Password=########;"
For Each fl In fld.Files
If fl.name Like Mask Then
strInput = fl.name
strFilePath = fld.path & "\" & fl.name
MsgBox (strFilePath)
adoStream.Type = adTypeBinary
adoStream.Open
adoStream.LoadFromFile strFilePath 'It fails if file is open
With adocmd
.CommandText = "INSERT INTO dbo.coc_upload(Data) " & _
"VALUES (?)"
.CommandType = adCmdText
'---adding parameters
.Parameters.Append .CreateParameter("#Data", adVarBinary, adParamInput, adoStream.Size, adoStream.Read)
'---
End With
adocmd.ActiveConnection = adoCon
adocmd.Execute
adoCon.Close
MsgBox ("Done")
End If
Next
Related
I'm trying to import multiple Excelfiles with multiple sheets.
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
strFileName = "C:\SomeFile\File.xlsx"
Set objWorkbook = objExcel.Workbooks.Open(strFileName)
Set colWorksheets = objWorkbook.Worksheets
For Each objWorksheet in colWorksheets
Set objRange = objWorksheet.UsedRange
strWorksheetName = objWorksheet.Name & "!" & objRange.Address(False, False)
objAccess.DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
"Vulnerability", strFileName, True, strWorksheetName
Next
I have a problem with the range. The variable strWorksheetName = "BE900!A1:L1634".
I get a runtime-error '3011'. The "!" is replaced by "$" so the sheet isn't found.
Any ideas?
ALL of my code
Public Function ImportFiles()
Dim strFolder As String
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim strFile As String
Dim strTable As String
Dim strExtension As String
Dim lngFileType As Long
Dim strSQL As String
Dim strFullFileName As String
Dim varPieces As Variant
With Application.FileDialog(3) ' msoFileDialogFolderPicker
.AllowMultiSelect = True
.Title = "Please select one or more files"
.Initialfilename = "*.xls*"
If .Show Then
strFullFileName = .SelectedItems(1)
Else
MsgBox "No folder specified!", vbCritical
Exit Function
End If
End With
strFile = Dir(strFolder)
Set db = CurrentDb()
strFile = Dir(strFolder & "*.xls*")
Do While Len(strFile) > 0
strTable = DetermineTable(strFile)
strSQL = "UPDATE [" & strTable & "] SET FileName=[pFileName]" & vbCrLf & _
"WHERE FileName Is Null OR FileName='';"
Set qdf = db.CreateQueryDef(vbNullString, strSQL)
varPieces = Split(strFile, ".")
strExtension = varPieces(UBound(varPieces))
Select Case strExtension
Case "xls"
lngFileType = acSpreadsheetTypeExcel9
Case "xlsx", "xlsm"
lngFileType = acSpreadsheetTypeExcel12Xml
Case "xlsb"
lngFileType = acSpreadsheetTypeExcel12
End Select
Set objexcel = CreateObject("Excel.Application")
Set objworkbook = objexcel.Workbooks.Open(strFullFileName)
Set colworksheets = objworkbook.Worksheets
For Each objWorksheet In colworksheets
Set objRange = objWorksheet.UsedRange
**strWorksheetName = objWorksheet.Name & "!" & objRange.Address(False, False)**
'strWorksheetName = objRange.Address(0, 0, external:=True)
DoCmd.TransferSpreadsheet _
TransferType:=acImport, _
SpreadsheetType:=lngFileType, _
tableName:=strTable, _
FileName:=strFile, _
HasFieldNames:=False, _
**Range:=CStr(strWorksheetName)**
Next
colworksheets.Close
colworksheets = Nothing
objworkbook.Close
objworkbook = Nothing
objexcel.Close
objexcel = Nothing
Set db = CurrentDb()
Set tdf = db.TableDefs(strTable)
'Add the field to the table.
If FieldExistsInTable(strTable, "FileName") = True Then
'Do nothing
Else
tdf.Fields.Append tdf.CreateField("FileName", dbText, 255)
'tdf.fields.append tdf.createField("SheetName", dbText, 255)
End If
'Supply the parameter value for the UPDATE and execute it ...
qdf.Parameters("pFileName").Value = strFile
qdf.Execute 'dbFailOnError
'Move to the next file
strFile = Dir
Loop
Set fld = Nothing
Set tdf = Nothing
Set db = Nothing
'rstTable.Close
Set rstTable = Nothing
End Function
Macro does not have an error, works well in my PC.
You can try a PC restart.
I this does not help, you may define strWorksheetName2, replace $ in strWorksheetName with !. Then give it to access object.
Rebuilded the code from scratch in a new db, now it works.
Thanks for the assistance.
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 got an Excel-Code to generate singular word-mailmerged-documents.
It all work fine. The only problem is that after running the code and closing excel there is still one word instance running in the taskmanager.
Can someone help me fixing this?
My code so far is:
Private Sub CommandButton1_Click()
Dim wordApp As Word.Application
Dim wordTemplate As Word.Document
Dim wordMergedDoc As Word.MailMerge
Dim sourceBookPath As String
Dim sheetSourceName As String
Dim excelColumnFilter As String
Dim queryString As String
Dim baseQueryString As String
Dim wordTemplateDirectory As String
Dim wordTemplateFileName As String
Dim wordTemplateFullPath As String
Dim wordOutputDirectory As String
Dim wordOutputFileName As String
Dim wordOutputFullPath As String
Dim idListValues As Variant
Dim idValue As Integer
Dim idCounter As Integer
Dim recordCounter As Integer
Dim fileCounter As Integer
idListValues = Array(1, 2, 3, 4, 5, 6, 7)
sourceBookPath = ThisWorkbook.FullName
sheetSourceName = "Sheet1"
excelColumnFilter = "Anz"
baseQueryString = "SELECT * FROM `" & sheetSourceName & "$` where `" & excelColumnFilter & "` = [columFilterValue] order by `" & excelColumnFilter & "` ASC"
' Word:
wordTemplateDirectory = ThisWorkbook.Path & "\"
wordTemplateFileName = "sb[columFilterValue].docx"
wordOutputDirectory = ThisWorkbook.Path & "\"
wordOutputFileName = "MailMergeDifferent[columFilterValue]_[Record]"
Set wordApp = New Word.Application
wordApp.Visible = False
wordApp.DisplayAlerts = wdAlertsNone
MsgBox "Verteidigungsanzeigen werden erstellt, bitte kurz warten :)", vbOKOnly + vbInformation, "Information"
For idCounter = 0 To UBound(idListValues)
idValue = idListValues(idCounter)
queryString = Replace(baseQueryString, "[columFilterValue]", idValue)
wordTemplateFullPath = wordTemplateDirectory & Replace(wordTemplateFileName, "[columFilterValue]", idValue)
Set wordTemplate = wordApp.Documents.Open(wordTemplateFullPath)
Set wordMergedDoc = wordTemplate.MailMerge
With wordMergedDoc
.MainDocumentType = wdFormLetters
.OpenDataSource _
Name:=sourceBookPath, _
ReadOnly:=True, _
Format:=wdOpenFormatAuto, _
Revert:=False, _
AddToRecentFiles:=False, _
LinkToSource:=False, _
Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;" & _
"Data Source=" & sourceBookPath & ";Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
SQLStatement:=queryString
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
For recordCounter = 1 To .DataSource.RecordCount
With .DataSource
.FirstRecord = wordMergedDoc.DataSource.ActiveRecord
.LastRecord = wordMergedDoc.DataSource.ActiveRecord
Dokumentenname = .DataFields("ID")
End With
.Execute Pause:=False
wordOutputFullPath = wordOutputDirectory & Replace(Replace(wordOutputFileName, "[columFilterValue]", idValue), "[Record]", recordCounter)
wordApp.ActiveDocument.SaveAs2 Filename:=wordOutputDirectory & Dokumentenname & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
wordApp.ActiveDocument.Close SaveChanges:=False
.DataSource.ActiveRecord = wdNextRecord
fileCounter = fileCounter + 1
Next recordCounter
End With
wordTemplate.Close False
Next idCounter
wordApp.Visible = False
Set wordApp = Nothing
MsgBox "Geschafft! Es wurden " & fileCounter & " Verteidigungsanzeigen erstellt", vbOKOnly + vbInformation, "Information"
End Sub
Try adding wordApp.Quit right before Set wordApp = Nothing
I am using Access VBA to import multiple Excel files into my Access database. This will be a monthly process with 20-50 files and 10-60K records. I need to include an "Application name" that isn't included within the spreadsheet file itself, but is in its file name. Rather than manually adding the application name to the Excel file I'd like to have it added via my VBA code.
I'm not proficient with Access and have pieced most of this together from searches on how to complete. This "works" but when I run it on larger batches I receive an error "Run-time error '3035': System resource exceeded.' When I remove the section that adds the file name (loop records) it runs fine. I think it's because the steps aren't ordered efficiently? Any help would be appreciated.
Public Function Import_System_Access_Reports()
Dim strFolder As String
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim fld As DAO.Field
Dim rstTable As DAO.Recordset
Dim strFile As String
Dim strTable As String
Dim lngPos As Long
Dim strExtension As String
Dim lngFileType As Long
Dim strSQL As String
Dim strFullFileName As String
With Application.FileDialog(4) ' msoFileDialogFolderPicker
If .Show Then
strFolder = .SelectedItems(1)
Else
MsgBox "No folder specified!", vbCritical
Exit Function
End If
End With
If Right(strFolder, 1) <> "\" Then
strFolder = strFolder & "\"
End If
strFile = Dir(strFolder & "*.xls*")
Do While strFile <> ""
lngPos = InStrRev(strFile, ".")
strTable = "RawData"
'MsgBox "table is:" & strTable
strExtension = Mid(strFile, lngPos + 1)
Select Case strExtension
Case "xls"
lngFileType = acSpreadsheetTypeExcel9
Case "xlsx", "xlsm"
lngFileType = acSpreadsheetTypeExcel12Xml
Case "xlsb"
lngFileType = acSpreadsheetTypeExcel12
End Select
DoCmd.TransferSpreadsheet _
TransferType:=acImport, _
SpreadsheetType:=lngFileType, _
TableName:=strTable, _
FileName:=strFolder & strFile, _
HasFieldNames:=True ' or False if no headers
'Add and populate the new field
'set the full file name
strFullFileName = strFolder & strFile
'Initialize
Set db = CurrentDb()
Set tdf = db.TableDefs(strTable)
'Add the field to the table.
'tdf.Fields.Append tdf.CreateField("FileName", dbText, 255)
'Create Recordset
Set rstTable = db.OpenRecordset(strTable)
rstTable.MoveFirst
'Loop records
Do Until rstTable.EOF
If (IsNull(rstTable("FileName")) Or rstTable("FileName") = "") Then
rstTable.Edit
rstTable("FileName") = strFile
rstTable.Update
End If
rstTable.MoveNext
Loop
strFile = Dir
'Move to the next file
Loop
'Clean up
Set fld = Nothing
Set tdf = Nothing
Set db = Nothing
'rstTable.Close
Set rstTable = Nothing
End Function
The code is simpler and run-time performance should be much better if you eliminate the Recordset. You can execute an UPDATE after each TransferSpreadsheet
Dim strFolder As String
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim strFile As String
Dim strTable As String
Dim strExtension As String
Dim lngFileType As Long
Dim strSQL As String
Dim strFullFileName As String
Dim varPieces As Variant
' --------------------------------------------------------
'* I left out the part where the user selects strFolder *'
' --------------------------------------------------------
strTable = "RawData" '<- this could be a constant instead of a variable
Set db = CurrentDb()
' make the UPDATE a parameter query ...
strSQL = "UPDATE [" & strTable & "] SET FileName=[pFileName]" & vbCrLf & _
"WHERE FileName Is Null OR FileName='';"
Set qdf = db.CreateQueryDef(vbNullString, strSQL)
strFile = Dir(strFolder & "*.xls*")
Do While Len(strFile) > 0
varPieces = Split(strFile, ".")
strExtension = varPieces(UBound(varPieces))
Select Case strExtension
Case "xls"
lngFileType = acSpreadsheetTypeExcel9
Case "xlsx", "xlsm"
lngFileType = acSpreadsheetTypeExcel12Xml
Case "xlsb"
lngFileType = acSpreadsheetTypeExcel12
End Select
strFullFileName = strFolder & strFile
DoCmd.TransferSpreadsheet _
TransferType:=acImport, _
SpreadsheetType:=lngFileType, _
TableName:=strTable, _
FileName:=strFullFileName, _
HasFieldNames:=True ' or False if no headers
' supply the parameter value for the UPDATE and execute it ...
qdf.Parameters("pFileName").Value = strFile
qdf.Execute dbFailOnError
'Move to the next file
strFile = Dir
Loop
I'm trying to join two CSV files.
Currently I'm trying to add the following code. I added a validation if the connection was open with the "If Not objConnection Is Nothing Then" but supposedly the connection is open. When I run the code I get the following error message:
which roughly translates to:
An error has occurred '2147217904 (80040e10)' in execution time:
Some required values have not been specified.
I have the following libraries loaded:
The code is as follows:
Dim objConnection As ADODB.Connection
Dim objrecordset As ADODB.Recordset
fNameAndPath = Application.GetOpenFilename(FileFilter:="CSV File (*.csv),(*.csv)", Title:="Select first CSV file")
If fNameAndPath = False Then
Exit Sub
End If
fNameAndPath2 = Application.GetOpenFilename(FileFilter:="CSV File (*.csv),(*.csv)", Title:="Select second CSV file")
If fNameAndPath2 = False Then
Exit Sub
End If
Set objConnection = CreateObject("ADODB.Connection")
Set objrecordset = CreateObject("ADODB.Recordset")
strPath = Left(fNameAndPath, InStrRev(fNameAndPath, "\") - 1)
Filename = Mid(fNameAndPath, InStrRev(fNameAndPath, "\") + 1)
strPath2 = Left(fNameAndPath2, InStrRev(fNameAndPath2, "\") - 1)
Filename2 = Mid(fNameAndPath2, InStrRev(fNameAndPath2, "\") + 1)
With objConnection
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Data Source=" & strPath & _
";Extended Properties=""text;HDR=Yes;FMT=Delimited"";"
.Open
End With
strSql = "SELECT * FROM " & Filename & " as file1, " _
& "" & Filename2 & " as file2" _
& " WHERE file1.[APOYO] = file2.[APOYO]"
If Not objConnection Is Nothing Then
If (objConnection.State And adStateOpen) = adStateOpen Then
Set objrecordset = objConnection.Execute(strSql)
End If
End If
Restarted from scratch.
This code works:
Sub leerCSV()
On Error Resume Next
Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adCmdText = &H1
Set objConnection = CreateObject("ADODB.Connection")
Set objRecordset = CreateObject("ADODB.Recordset")
strPathtoTextFile = "C:\"
objConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strPathtoTextFile & ";" & _
"Extended Properties=""text;HDR=YES;FMT=Delimited"""
strSql = "SELECT * FROM file.csv F1 " _
& " LEFT JOIN file2.csv F2 ON F1.[c1] = F2.[c1] "
objRecordset.Open strSql, objConnection, adOpenStatic, adLockOptimistic, adCmdText
MsgBox "Registros: " & objRecordset.RecordCount
Debug.Print Now
Do Until objRecordset.EOF
Debug.Print "Name: " & objRecordset.Fields.Item("APOYO") & " Department: " & objRecordset.Fields.Item("O&D") & " Extension: " & objRecordset.Fields.Item("FECHA")
objRecordset.MoveNext
Loop
''Tidy up
objRecordset.Close
objConnection.Close
End Sub