I've been fighting for a long time with import formula record in database (=45+5 or =SUM(D20:D23)) to Excel worksheet. My problem is when I import formula from database in Excel cell is raw text from database record (=45+5 or =SUM(D20:D23)).
It's fine, but I'm not able to calculate this formula. I've tried options in VBA after importing from database like:
ActiveSheet.Calculate, Worksheets(1).Calculate, ActiveWorkbook.Calculate
Only manual one manual option works. When I set to cell with formula and hit ENTER.
But I want to automate this process.
----EDIT----
Original code:
Sub GetDataFieldInfo()
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim address_complete As String
Dim address_column As Integer
Dim address_row As Integer
Dim j As Integer
db_file = ThisWorkbook.Path & "\Example_db.mdb"
Set conn = New ADODB.Connection
conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
";Data Source=" & db_file & _
";Persist Security Info=False"
conn.Open
Set rs = conn.Execute("SELECT * FROM Students")
For i = 0 To rs.Fields.Count - 1
address_complete = findCellAddress(rs(i).Name)
address_row = Range(address_complete).Row
address_column= Range(address_complete).Column
rs.MoveFirst
j = 0
Do Until rs.EOF
If InStr(1, rs.Fields(rs(i).Name), "=", 1) Then
Cells(address_row + 1 + j, address_column).Formula = rs.Fields(rs(i).Name).Value
Else
Cells(address_row + 1 + j, address_column).Value = rs.Fields(rs(i).Name)
End If
j = j + 1
rs.MoveNext
Loop
Next
rs.Close
End Sub
You are probably doing Range("A1") = "=SUM(D20:D23)".
Instead of this you should do Range("A1").value = "=SUM(D20:D23)".
If this is not the case, please show us the VBA code you are using to export from msaccess to excel. It will help a lot.
Related
Hi Im making a Excel Form in which my Database is an access.
First I Encode data in Excel then Using Command Button to Post these data.
The code within the Command Button.. first get the Max Number from Access and use that Number to Complete the Data in Excel to be exported to Access. The Problem is If I use 2 and above users to simultaneously Post it will consolidate all the data into one with the same Number.
What I want is to lock opening data until posted since i need to get the max number of a column then add 1 first then import a complete set of data including the MAX number as a control number.
I tried using Do While adStateOpen <> 1 and also Do While IsRecordBusy = True then wait and loop and set the recordset to nothing instead of closing it twice. But it wont work it will consolidate the data with the same control number.
Below is my Code
Option Explicit
Sub ImportJEData()
Dim cnn As ADODB.Connection 'dim the ADO collection class
Dim rst As ADODB.Recordset 'dim the ADO recordset class
Dim dbPath
Dim x As Long, i As Long
Dim nextrow As Long
Dim Var
Dim LockType
Dim SQL
Dim IsRecordBusy
'add error handling
On Error GoTo errHandler:
'Variables for file path and last row of data
dbPath = Sheets("Update Version").Range("b1").Value
Set Var = Sheets("JE FORM").Range("F14")
nextrow = Sheets("LEDGERTEMPFORM").Cells(Rows.Count - 5, 1).End(xlUp).Row
'Initialise the collection class variable
Set cnn = New ADODB.Connection
'Create the ADODB recordset object. for Max Number
Set rst = New ADODB.Recordset 'assign memory to the recordset
LockType = adLockPessimistic
'Do While adStateOpen <> 1
Do While IsRecordBusy = True
Application.Wait (Now + TimeValue("0:00:01") / 1000)
Loop
SQL = "SELECT distinct Max(DVNumber),Max(ChckID) FROM DV "
rst.Open SQL, cnn
Sheets("Max").Range("A2").CopyFromRecordset rst
Set rst = Nothing
Set rst = New ADODB.Recordset 'assign memory to the recordset
rst.Open Source:="DV", ActiveConnection:=cnn, _
CursorType:=adOpenDynamic, LockType:=adLockPessimistic, _
Options:=adCmdTable
On Error Resume Next
'you now have the recordset object
'add the values to it
For x = 7 To nextrow
rst.AddNew
For i = 1 To 37
rst(Sheets("LEDGERTEMPFORM").Cells(6, i).Value) = Sheets("LEDGERTEMPFORM").Cells(x, i).Value
Next i
rst.Update
Next x
'close the recordset
rst.Close
' Close the connection
cnn.Close
'clear memory
Set rst = Nothing
Set cnn = Nothing
'Update the sheet
Application.ScreenUpdating = True
'Clear the data
On Error GoTo 0
Exit Sub
errHandler:
'clear memory
Set rst = Nothing
Set cnn = Nothing
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Export_Data"
End Sub
Im finally done with this code. I just added another Table in access where such table is unique the uses sql to get the max+1 and insert it back and loop it if error occurs because of the duplicate. Heres the code below
Do
On Error Resume Next 'reset Err.obj.
'Get the Max ID +1
Set rst = Nothing
Set rst = New ADODB.Recordset 'assign memory to the recordset
SQL = "SELECT Max(ApNumber)+1 FROM PayVoucherID "
rst.Open SQL, cnn
'Check if the recordset is empty.
'Copy Recordset to the Temporary Cell
Sheets("MAX").Range("A2").CopyFromRecordset rst
'Insert the Data to Database And Check If no Errors
Sql2 = "INSERT INTO PayVoucherID(ApNumber)Values('" & Sheets("MAX").Range("A2") & "') "
cnn.Execute Sql2
Loop Until (Err.Number = 0)
Hope this helps for Excel Front users.
I have an sql query that is running in a loop in excel. It works while the array is small. However the array is now up to around 4000 items and it causes excel to crash. Is there a better way to do this, am I missing some easy way to do this
For k = 0 To ubound(sqlarray)
Dim conn As ADODB.Connection
Dim recst As ADODB.Recordset
Dim sqlstring As String
Set conn = New ADODB.Connection
Set recst = New ADODB.Recordset
conn.ConnectionString = "Driver={Client Access ODBC Driver (32-
bit)};System=mysys ;NAM=1;CurrentSchema=myschema;"
conn.Open
Sql = "Select ACCOUNT_NBR, ASSIGNED_TO from prodlib.gr_exp_account where
account_nbr in ('" & sqlarray(k) & "' )"
Set recst.ActiveConnection = conn
recst.Open Sql, conn
Sheets("recst").Range("A" & k).CopyFromRecordset recst
conn.Close
Application.ScreenUpdating = True
Next k
End Sub
As noted in my comment above you should be submitting a single SQL statement and getting a single result set back. Looping through every customer and submitting SQL for it is bad.
Consider something like the following:
Sub whatever(sqlArray as string)
'initialize these outside your loop next time too
Dim conn As ADODB.Connection
Dim recst As ADODB.Recordset
Dim sqlstring As String
Set conn = New ADODB.Connection
Set recst = New ADODB.Recordset
conn.ConnectionString = "Driver={Client Access ODBC Driver (32-
bit)};System=mysys ;NAM=1;CurrentSchema=myschema;"
conn.Open
'All the accounts in one list in one statement. Use array function 'Join'
'to make the array a comma delimited string (or comma with quotes as a delim)
Sql = "Select ACCOUNT_NBR, ASSIGNED_TO from prodlib.gr_exp_account where
account_nbr in ('" & Join(sqlArray, "','") & "' )"
Set recst.ActiveConnection = conn
recst.Open Sql, conn
'Drop the entire recordset in a sheet starting at "A1"
Sheets("recst").Range("A1").CopyFromRecordset recst
conn.Close
Application.ScreenUpdating = True
End Sub
If JOIN() has a problem with the size of the array, or your database is complaining about the number of accounts you are sending in at a time, you could still loop, but using bigger chunks:
Sub whatever(sqlArray As String)
'initialize these outside your loop next time too
Dim conn As ADODB.Connection
Dim recst As ADODB.Recordset
Dim sqlstring As String
Set conn = New ADODB.Connection
conn.ConnectionString = "Driver={Client Access ODBC Driver (32-bit)};System=mysys ;NAM=1;CurrentSchema=myschema;"
conn.Open
Dim k As Integer
Dim chunk As Integer
'Set this to how many accout numbers you can squeeze through in a single request safely
chunk = 400
For k = 1 To UBound(sqlArray) Step chunk
'reset this object in the loop
Set recst = New ADODB.Recordset
'All the accounts in one list in one statement. Use array function 'Join'
'to make the array a comma delimited string (or comma with quotes as a delim)
Sql = "Select ACCOUNT_NBR, ASSIGNED_TO from prodlib.gr_exp_account where account_nbr in ('" & Join_With_Limit(sqlArray, "','", chunk, k) & "' )"
Set recst.ActiveConnection = conn
recst.Open Sql, conn
Sheets("recst").Range("A" & k).CopyFromRecordset recst
'close this for the next loop
recst.close
Next k
conn.Close
Application.ScreenUpdating = True
End Sub
Function Join_With_Limit(inArray As Variant, strDelim As String, intLimit As Integer, intOffset As Offset) As String
Dim i As Integer
For i = intOffset To intOffset + intLimit
'make sure we are below the ubound of the array
if i > uBound(inArray) Then Exit For
'If this isn't the first thing we are adding, then stick the delimiter
'before dropping in the value
If i <> intOffset Then Join_With_Limit = Join_With_Limit + strDelim
'Add the next item
Join_With_Limit = Join_With_Limit + inArray(i)
Next i
End Function
I have been doing some database work with excel both as the database and the database driver via macros with vba. I built a function that should parse through a list of database records with testID fields. I wanted to display each test only once based on it's testID, but the way the database is set up means I have to eliminate duplicate testID's. I do this by iterating through the recordset and checking the current test against the previous one before showing in the list. The problem I'm having is that the function is excruciatingly slow. For only 12 tests in the database, it takes about 3 seconds to display them in the view spreadsheet. I'd love to hear some ideas on how to optimize the run-time. Here's the function:
Public Function showAllTests()
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim cstring, sql As String
Dim r, c As Integer
Dim testsAr As Variant
Dim inAr As Boolean
cstring = "Provider = Microsoft.ACE.OLEDB.12.0; Data Source=I:\DBtrials.xlsx; Extended Properties=""Excel 12.0 Xml; HDR=YES;ReadOnly=False"";"
sql = "SELECT [TestID], [Status], [PFIBox], [WireType], [StartingDia], [Customer], [numSamples], [Assigned] FROM [Tests$]"
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
Call conn.Open(cstring)
Set rs = conn.Execute(sql)
If rs.EOF Then
Range("C6:J1000").ClearContents
End If
r = 6
count = 0
'Iterates through the recordset, eliminating duplicates and populating cells in the tests sheet
While Not rs.BOF And Not rs.EOF
Dim prevID, currID As String
Dim currCell As Range
inAr = False
If Not count = 0 Then
prevID = ActiveWorkbook.Sheets("Tests").Cells(r - 1, 3).Value
currID = CStr(rs(0))
If prevID = currID Then
inAr = True
End If
End If
For c = 3 To (rs.Fields.count + 2)
Set currCell = ActiveWorkbook.Sheets("Tests").Cells(r, c)
If Not IsNull(rs(c - 3).Value) And inAr = False Then
currCell.Value = CStr(rs(c - 3))
ElseIf IsNull(rs(c - 3).Value) Then currCell.Value = ""
Else:
Exit For
End If
Next c
If inAr = False Then
r = r + 1
End If
rs.MoveNext
count = count + 1
Wend
conn.Close
Set conn = Nothing
End Function
use GROUP BY
sql = "SELECT [TestID], [Status], [PFIBox], [WireType], [StartingDia], [Customer], [numSamples], [Assigned] FROM [Tests$] GROUP BY [TestID]"
Also some of these drivers - Microsoft.ACE.OLEDB.12.0 etc have terrible perfomance in VBA. sometimes i get better perforamance from OBDC 6.2 than ADO
I have a large view created in vfp. The view reached around 4 million record. I need to connect to it in and import it in an excel workbook.
While importing an error occurred that the worksheet reached it limits around (1.5 million record).
Any solutions? I am thinking of importing it in shunks to different worksheets but found no solutions yet.
This is MS Excel restriction. You cannot avoid this. Or export to another format insted of Excel sheet.
4 million records is really too much for excel. But if you have to you should connect to the dbf folder through vba and pump the data manually into excel.
But that is going to be really slow.
Here is code you can use.
It imports 1.5 mill lines into each worksheet and that is problably too much. I would use 100.000 lines or so. but thats your call
I havent run it but should be about right.
Option Explicit
Sub import()
Dim con As Object
Dim rst As Object
Dim sql As String
Dim DbFolderPath As String
Dim i As Long
Dim ii As Integer
DbFolderPath = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
Set con = CreateObject("ADODB.connection")
con.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DbFolderPath & ";Extended Properties=dBASE IV;"
sql = "SELECT * FROM myquery"
Set rst = CreateObject("ADODB.recordset")
rst.CursorLocation = 3 'adUseClient
rst.CursorType = 1 'adOpenKeyset
rst.Open sql, con
ReDim myValues(rst.RecordCount, 4)
ThisWorkbook.Sheets(0).Activate
i = 1
ii = 0
If Not (rst.EOF And rst.BOF) Then
rst.MoveFirst
Do Until rst.EOF = True
Cells(i, 1) = rst!Field1
Cells(i, 2) = rst!Field2
rst.MoveNext
i = i + 1
If i > 1500000 Then
i = 1
ii = ii + 1
ThisWorkbook.Worksheets.Add
ThisWorkbook.Sheets(ii).Activate
End If
Loop
Else
GoTo cleanup
End If
Columns("A:B").EntireColumn.AutoFit
GoTo cleanup
Exit Sub
cleanup:
On Error Resume Next
rst.Close
con.Close
Set rst = Nothing
Set con = Nothing
Application.ScreenUpdating = True
Exit Sub
End Sub
I'm trying to take an ADO Recordset and then loop through it to parse individual rows to different worksheets within an Excel workbook. Unfortunately, as I step through my code, I get the following error: Run-time error '13': Type mismatch. This occurs when I call the sub in my code - it never actually steps into the sub. I'm wondering if I'm somehow not passing the Recordset in correctly or if it's a problem somewhere within my loop.
Regardless, here's my code - any help is greatly appreciated!
Sub SplitData(ByVal rs As ADODB.Recordset)
' Instantiate count variables for each result type
' Start at 2 to give room for Table headers on sheets
Dim NewAppsCount, BadLogCount, MatNotesCount, ZeroBalCount As Integer
NewAppsCount , BadLogCount, MatNotesCount, ZeroBalCount = 2
' Row Counter
Dim Count As Long
Count = 0
' Loop through the recordset and parse rows to appropriate worksheets
Do While Not rs.EOF
If CStr(rs.Fields("Maturity Date")) = "" Then
If CStr(rs.Fields("Log_Date")) = "" Then
' Applications that have not been properly logged
Sheet4.Range("A" & CStr(BadLogCount)) = rs.Fields(Count).Value
Count = Count + 1
BadLogCount = BadLogCount + 1
Else
' New Applications
Sheet6.Range("A" & CStr(NewAppsCount)) = rs.Fields(Count).Value
Count = Count + 1
NewAppsCount = NewAppsCount + 1
End If
Else
If Month(rs.Fields("Maturity Date")) < Month(Date) Then
' Maturing Notes with Zero Outstanding Balance
Sheet7.Range("A" & CStr(ZeroBalCount)) = rs.Fields(Count).Value
Count = Count + 1
ZeroBalCount = ZeroBalCount + 1
Else
' Maturing Notes
Sheet8.Range("A" & CStr(MatNotesCount)) = rs.Fields(Count).Value
Count = Count + 1
MatNotesCount = MatNotesCount + 1
End If
End If
rs.MoveNext
Loop
End Sub
Here is the sub that call GetData:
Sub GetData(ByVal Update As Boolean)
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim query As String
Dim path As String
Dim prompt, result As Integer
Dim day, today As String
' ...skipping stuff not related to the issue...
' Set the UNC Path
path = "\\this\is\the\path"
' Instantiate ADO Objects
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
' Connect to data source
conn.Open "Provider=Microsost.JET.OLEDB.4.0;Data Source=" & path & ";"
' The Query
query = "This is a big 'ol query that I won't repost here"
'Run the query and populate the Recordset object
rs.CursorLocation = adUseClient
rs.Open query, conn, adOpenStatic, adLockReadOnly
'Parse contetns of Recordset to worksheet
Application.ScreenUpdating = False
Me.SplitData(rs)
'Close the ADO Objects, set them to null, and exit sub
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
Exit Sub
End Sub
Try changing:
Me.SplitData(rs)
to:
Me.SplitData rs
Unnecessary parentheses often cause problems in VBA.
(NB I'm assuming that the two Sub shown are in a context where Me makes sense - e.g. class module, ThisWorkbook module, worksheet module, backing a UserForm etc)