I have Googled without much luck. Basically each creation of a excel spreadsheet (based on a template), needs to be password protected. Can this be done?
'______________________CreateExcel()____________________________________
Function CreateExcel()
SELECT DATA FROM SQL TABLE
If objStructure.BOF = False And objStructure.EOF = False Then
Do While objStructure.EOF = False
Call CreateActualExcel()
objRsExcel.Fields("Field") = objStructure.Fields("Field")
objStructure.MoveNext
Loop
End If
End Function
'......................End CreateExcel()..................................
'______________________CreateActualExcel()________________________________
Sub CreateActualExcel()
Dim objSFSO
Dim strCon, strSQL
strFile = " Staffing_List_" & Clng(Timer()) & ".xls"
Set objSFSO = CreateObject("Scripting.FileSystemObject")
objSFSO.CopyFile conFolder & conTemplate, conFolder & strFile
Set objSFSO = Nothing
Set objRsExcel = CreateObject("ADODB.RecordSet")
strCon = _
"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & _
conFolder & strFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes;maxscanrows=1;"";"
strSQL = "Select * From [Sheet1$]"
objRsExcel.Open strSql, strCon, 3, 2
End Sub
'......................End CreateActualExcel()............................
Thanks in advance for any help.
Clare :-)
I think you can pass the password as an additional parameter when you save the file.
excelObj.SaveAs "C:\Example.xls",,"your-password"
I haven't tested this but I found this blog post about it:
http://qtp.blogspot.co.uk/2010/04/vbscript-excel-password-protect.html
Related
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)
I retrieve data from SQL Server and store it on a sheet in Excel and then I run an ADO UPDATE query within Excel to update data on a different sheet.
I have not come across this error during developing yet users are reporting they see this error frequently:
Note that the file is located on a network drive, but even after copying the file to a different location, it is still producing said error.
Code:
Dim rs As New ADODB.Recordset
Dim cmd As New ADODB.Command
Dim cnn As New ADODB.Connection
Application.ScreenUpdating = False
Application.EnableEvents = False
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & ThisWorkbook.FullName & "';" & _
"Extended Properties=""Excel 12.0;HDR=YES;"";"
Set rs = GetOverview
shUpdateSLSheet.UsedRange.clear
WriteHeadersToSheet rs, shUpdateSLSheet.Name, 1
shUpdateSLSheet.Range("A2").CopyFromRecordset rs
If (rs.EOF And rs.BOF) Then GoTo NoData
cmd.ActiveConnection = cnn
cmd.CommandType = adCmdText
cmd.CommandText = "UPDATE [SL$] INNER JOIN [UpdateSLSheet$] " & _
"ON ([SL$].ID = [UpdateSLSheet$].ID) " & _
"SET [SL$].[CS_A] = [UpdateSLSheet$].[CS_A]" & _
", [SL$].[CS_B] = [UpdateSLSheet$].[CS_B]" & _
", [SL$].[CS_C] = [UpdateSLSheet$].[CS_C]" & _
", [SL$].[CS_D] = [UpdateSLSheet$].[CS_D]" & _
", [SL$].[CS_E] = [UpdateSLSheet$].[CS_E]" & _
", [SL$].[CS_F] = [UpdateSLSheet$].[CS_F]" & _
", [SL$].[Solved By SR] = [UpdateSLSheet$].[SolvedBySR]" & _
", [SL$].[Comments] = [UpdateSLSheet$].[Comments]"
cmd.Execute
Application.EnableEvents = True
Application.ScreenUpdating = True
Set cmd = Nothing
Set rs = Nothing
Set cnn = Nothing
As soon as cmd.Execute gets executed the error comes up.
EDIT: I have no clue why this is happening. I'm going for an iterative approach instead of using ADO in this case.
you have to use the open method for the record set and use the lock type
so the data base actual locked when some one is adding and when this person finish adding the data base will save changes and then another person can start adding
A bit late, but I had the same issue and found a solution: I tried using the OLD driver in the connection string, and it worked like a charm, even if the workbook is an XLSM !
Hope it helps someone.
sConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & wbName
sConn2 = ";Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
On Error GoTo hell
Set con = New ADODB.Connection
'con.Open sConn & sConn2
con.Open "Driver={Microsoft Excel Driver (*.xls)};" & _
"DriverId=790;" & _
"Dbq=" & wbName & ";" & _
"DefaultDir=" & wbname & ";ReadOnly=False;"
I am trying to do a Join on 3 tables in Excel through VBA using Microsoft.ACE.OLEDB.12.0. Having lots of issues trying to get the query to run. At this point I get the following error:
Run-time error '-2147217865 (800040e37)':
The Microsoft Access database engine could not find the object 'CustomSheetName1$A$1:$AV$6027'. Make sure the object exists and that you spell its name and the path name correctly. If 'CustomSheetName1$A$1:$AV$6027' is not a local object, check your network connection or contact the server administrator.
The source file is created in the same sub and saved to the macro root folder located locally in C:\Users\localuser\Documents\MacroFolder\. I have full access to the file.
When run the connection string shows as:
"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\localuser\Documents\MacroFolder\Book4.xlsx;Extended Properties='Excel 12.0 Xml;HDR=Yes;IMEX=1';"
Extract of sub below. I have obfuscated the field names and only included code I thought was relevant. Can add more and clarify further if required. Code breaks at the last line when executing the query.
Dim wbTarget As Workbook, wsTarget As Worksheet
Dim wb As Workbook, ws As Worksheet
Set wbTarget = Workbooks.Add
Set wsTarget = wbTarget.Sheets.Add(After:=wbTarget.Sheets(wbTarget.Sheets.Count))
wsTarget.Name = "CustomSheetName1"
varFilePathElements = Split(ThisWorkbook.Path, "\")
strFileName = varFilePathElements(UBound(varFilePathElements))
Dim strWBTargetFullFileName As String
strWBTargetFullFileName = Replace(ThisWorkbook.Path, "strfilename", "") & "\" & wbTarget.Name & ".xlsx"
Dim cn As Object
Dim rs As Object
Dim strCon As String
Dim strSQL As String
Dim s As String
Dim i As Integer, j As Integer
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strWBTargetFullFileName _
& ";Extended Properties='Excel 12.0 Xml;HDR=Yes;IMEX=1';"
strSQL = "SELECT " _
& "sh1.company_name, " _
& "sh1.company_type, " _
& "sh1.customer_no, " _
& "sh1.fk1, " _
& "SUM(sh3.total_stat) as total_stat, " _
& "FROM ( [CustomSheetName1" & wbTarget.Sheets("CustomSheetName1").UsedRange.Address & "] sh1 " _
& "LEFT JOIN [CustomSheetName2" & wbTarget.Sheets("CustomSheetName2").UsedRange.Address & "] sh2 " _
& "ON sh2.fk1 = sh1.fk1 ) " _
& "LEFT JOIN [CustomSheetName3" & wbTarget.Sheets("CustomSheetName3").UsedRange.Address & "] sh3 " _
& "ON sh3.fk2 = sh2.fk2 AND sh3.fk3 = sh2.fk3 " _
& "GROUP BY sh1.customer_no, sh1.company_name, sh1.company_type, sh1.fk1 " _
& "ORDER BY total_stat"
wbTarget.Sheets(1).Range("A1").Value2 = strSQL
wbTarget.SaveAs (strWBTargetFullFileName)
wbTarget.Close
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open strCon
rs.Open strSQL, cn, 3, 3
Any help would be greatly appreciated. Regards,
When reading Excel worksheets via ADO, the $ sign is appended to the end of the worksheet name, like this:
SELECT * FROM [Sheet1$]
Using the absolute range address adds extra $ signs that cause the worksheet name to be interpreted incorrectly. You need to use non-absolute range addresses to stop this happening. Adding some parameters to UsedRange.Address can fix this:
[CustomSheetName1$" & wbTarget.Sheets("CustomSheetName1").UsedRange.Address(False, False) & "]
I tried the code in this link to push and retrieved the data between Excel and Access. I modified the code based on my file path as following:
EDITED NEW CODE BLOCK
Sub UpdateMDB()
Dim accConn As Object, accRST As Object
Dim accFile As String, accStr As String
Dim lastrow As Long, i As Long
lastrow = Workbooks(1).Sheets(1).Cells(Workbooks(1).Sheets(1).Rows.Count, "A").End(xlUp).Row
accFile = "Z:\Documents\Database\Database1.mdb"
accStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & accFile & ";"
Set accConn = CreateObject("ADODB.Connection")
Set accRST = CreateObject("ADODB.Recordset")
accConn.Open accStr
accRST.Open "SELECT * FROM Table1", accConn, adOpenKeyset, adLockOptimistic, adCmdTableDirect
If Not (accRST.BOF And accRST.EOF) Then
accRST.MoveFirst
Else
MsgBox "No records in Access table.", vbInformation
accRST.Close: accConn.Close: Set accRST = Nothing: Set accConn = Nothing
Exit Sub
End If
Do While Not accRST.EOF
For i = 1 To lastrow
If accRST!ID = Workbooks(1).Sheets(1).Range("A" & i) _
And accRST!Field1 <> Workbooks(1).Sheets(1).Range("B" & i) Then
accRST!Field1.Value = Workbooks(1).Sheets(1).Range("B" & i)
End If
Next i
accRST.Update
accRST.MoveNext
Loop
accRST.Close: accConn.Close
Set accRST = Nothing: Set accConn = Nothing
End Sub
INITIAL CODE BLOCK
Sub GetMDB()
Dim cn As Object
Dim rs As Object
strFile = "Z:\Documents\Database\Database1.mdb"
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile & ";"
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open strCon
strSQL = "SELECT * FROM Table1"
rs.Open strSQL, cn
With Worksheets(1)
For i = 0 To rs.Fields.Count - 1
.Cells(1, i + 1) = rs.Fields(i).Name
Next
rs.MoveFirst
.Cells(2, 1).CopyFromRecordset rs
End With
End Sub
Sub UpdateMDB()
Dim cn As Object
Dim rs As Object
''It would probably be better to use the proper name, but this is
''convenient for notes
strFile = Workbooks(1).FullName
''Note HDR=Yes, so you can use the names in the first row of the set
''to refer to columns
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open strCon
''Selecting the cell that are different
strSQL = "SELECT * FROM [Sheet1$] s " _
& "INNER JOIN [;Database=Z:\Documents\Database\Database1.mdb;].Table1 t " _
& "ON s.id=t.id " _
& "WHERE s.Field1<>t.Field1"
rs.Open strSQL, cn, 1, 3 ''adOpenKeyset, adLockOptimistic
''Just to see
''If Not rs.EOF Then MsgBox rs.GetString
''Editing one by one (slow)
rs.MoveFirst
Do While Not rs.EOF
rs.Fields("t.Field1") = rs.Fields("s.Field1")
rs.Update
rs.MoveNext
Loop
''Batch update (faster)
strSQL = "UPDATE [;Database=Z:\Documents\Database\Database1.mdb;].Table1 t " _
& "INNER JOIN [Sheet1$] s " _
& "ON s.id=t.id " _
& "SET t.Field1=s.Field1 " _
& "WHERE s.Field1<>t.Field1 "
cn.Execute strSQL
End Sub
Reading data from Access to Excel GetMDB() macro works fine, But when I tried to update the data from Excel to Access, code gives me following error:
Run-time error '3021':
Either BOF or EOF is True, or the current record has been deleted.
Requested operation requires a current record.
I checked the mdb, xlsx and sheet path and names are correct. Anyone got a similar problem as well and how to overcome? Thanks.
You cannot run UPDATE queries using Excel workbook sources as any SQL queries using workbooks are read-only from last saved instance and cannot be updated. Excel simply is not a database to do such transactions with no record-level locking mechanism, read/write access, or relational model. Though you can run append (INSERT INTO ... SELECT *) and make-table queries (SELECT * INTO FROM ...), you cannot run UPDATE that aligns to live values.
However, you can read in an Access recordset and iterate through the Excel cells aligning by ID matches. Below assumes the Excel Sheet's ID column is in Column A and Field1 is in Column B.
Dim accConn As Object, accRST As Object
Dim accFile As String, accStr As String
Dim lastrow As Long, i As Long
Const adOpenKeyset = 1, adLockOptimistic = 3, adCmdTableDirect = 512
lastrow = Workbooks(1).Sheets(1).Cells(Workbooks(1).Sheets(1).Rows.Count, "A").End(xlUp).Row
accFile = "Z:\Documents\Database\Database1.mdb"
accStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & accFile & ";"
Set accConn = CreateObject("ADODB.Connection")
Set accRST = CreateObject("ADODB.Recordset")
accConn.Open accStr
accRST.Open "SELECT * FROM Table1", accConn, adOpenKeyset, adLockOptimistic, adCmdTableDirect
If Not (accRST.BOF And accRST.EOF) Then
accRST.MoveFirst
Else
Msgbox "No records in Access table.", vbInformation
accRST.Close: accConn.Close: Set accRST = Nothing: Set accConn = Nothing
Exit Sub
End If
Do While Not accRST.EOF
For i = 1 to lastrow
If accRST!ID = Workbooks(1).Sheets(1).Range("A" & i) _
And accRST!Field1 <> Workbooks(1).Sheets(1).Range("B" & i) Then
accRST!Field1.Value = Workbooks(1).Sheets(1).Range("B" & i)
End If
Next i
accRST.Update
accRST.MoveNext
Loop
accRST.Close: accConn.Close
Set accRST = Nothing: Set accConn = Nothing
Notes:
If IDs between Excel worksheet and Access table are not one-to-one (i.e., Excel has multiple rows of same ID), the last Field1 value following the If logic will be inserted to corresponding Access row.
Above may be extensive processing if database rows and Excel cells are large. The best option is simply to use Access for all data entry/management and avoid the update needs. Since Excel is a flatfile, consider using it as the end use application and Access as central data repository.
I am working with the Microsoft OLE DB Provider for Jet to execute queries on spreadsheets in Excel using VBA. Is there a way to execute the following code on an unsaved workbook?
For example, ActiveWorkbook.FullName returns "Book1" if the workbook has never been saved. In that case the Data Source will assume the path is the active directory, and error out because the file was never saved.
Is there any way to use the Excel temporary file as the Data Source for Jet? I would like to test this but I don't even know how to return the Path and Name for the Excel temporary file.
Public Sub LocalJetQuery()
Dim objStartingRange As Range
Dim objConnection As New ADODB.Connection
Dim objRecordset As New ADODB.Recordset
Dim strDSN As String
Dim strSQL As String
Set objStartingRange = Application.Selection
If CLng(Application.Version) >= 12 Then
strDSN = "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "Data Source=" & objStartingRange.Worksheet.Parent.FullName & ";" _
& "Extended Properties=""Excel 12.0 Xml;HDR=No;IMEX=1"";"
Else
strDSN = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=" & objStartingRange.Worksheet.Parent.FullName & ";" _
& "Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
End If
strSQL = "SELECT * FROM [" & objStartingRange.Worksheet.Name & "$];"
objConnection.Open strDSN
objRecordset.Open strSQL, objConnection
Application.Workbooks.Add(xlWBATWorksheet).Sheets(1).Cells(1, 1).CopyFromRecordset objRecordset
End Sub
Thanks!
No. Just like David Fenton says in the comments.