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)
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 been looking for a solution to inserting data into excel using vb6 code and access database. There are many cases where I need to write to an excel spreadsheet multiple times with different records of data. I have an existing workbook that I am trying to open and "save as" when I am complete. I have been able to open the excel workbook, access the sheet I am writing to, and the cells I am writing to, however I can only write to the workbook once and when I leave the scope of the open workbook the connection is closed.
I have a sub routine that creates the workbook object, opens the existing workbook and work sheet, writes to a specified cell number to insert the new data. I have looked at official support pages and it doesn't seem to have what I am looking for at this time.
Am I making this too complicated or is there a solution for this? Please help.
My current code:
Row Arrays
Private oldDataRowArray(3 To 21) As Integer
Private updatedDataRowArray(5 To 2) As Integer
Loop logic
Dim i As Integer
Dim n As Integer
i = 3
n = 5
Do While i <= UBound(oldDataRowArray) And n <= UBound(updatedDataRowArray)
EditExcelSheet txtWorkbookFileName.Text, i, n //sub routine
i = i + 3 //skip number of cells
n = n + 3 //skip number of cells
Loop
Sub Routine to Insert data into Excel
Private Sub EditStakingSheet(ByVal workbook As String, ByVal oldDataRowIndex As Integer, ByVal newDataRowIndex As Integer)
Dim objExcel As Object
Dim objWorkBook As Object
Dim objSheet As Object
Set objExcel = New Excel.Application
Set objWorkBook = objExcel.Workbooks.Open(workbook)
Set objSheet = objWorkBook.Worksheets(1)
objExcel.Visible = True
//insert old value
objSheet.Cells(oldDataRowIndex , 26).Value = "old Value"
//insert new value
objSheet.Cells(newDataRowIndex , 26).Value = "new Value"
End Sub
You could use adodb objects.
This video is a good tutorial for this.
Here is an example how you can use adodb. You need to install the activeX Data Objects Libary for this.
For .source= you can use any sql-query.
Public Function get_Value(table As String, order_by As String) As Variant
Set db_data = New ADODB.Recordset
Set db1 = New ADODB.Connection
pDB_path = "#enter db-path here"
db1.ConnectionString = _
"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & pDB_path & ";Persist Security Info=False;"
db1.Open
With db_data
.ActiveConnection = db1
.Source = "SELECT * FROM " & table & " ORDER BY " & order_by & " ASC"
.LockType = adLockReadOnly 'read only access to db
.CursorType = adOpenStatic 'how to update the database
.Open
End With
get_Value = TransposeArray(db_data.GetRows)
db_data.Close
End Function
I've Searched Forums here and I can't seem to get this code to work.
I am Trying to Open a Workbook in Excel, and then populate a few of the Cells(Named Ranges). I can successfully open the workbook(the workbook has a bit of VBA that runs when it opens as well, formatting stuff only) but when I get down to the inputting information I get a 'Run-Time Error "438" Object Doesn't support this property or method.'
From the Previous answers on other similar questions I have done everything the way it was suggested however, I can't seem to get it to work.
Option Compare Database
Option Explicit
Public Sub MaterialInput()
Dim xlapp As Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim RsClient As Recordset
Dim RsJobsite As Recordset
Dim db As Database
Dim ClientSTR As String
Dim JobsiteSTR As String
Dim customer As Variant
Set db = CurrentDb
JobsiteSTR = "SELECT T1Jobsites.JobsiteNickName FROM T1Jobsites WHERE T1Jobsites.JobsiteID = 1" ' & Form_LEM.TxtJobsiteID
Set RsJobsite = db.OpenRecordset(JobsiteSTR, dbOpenSnapshot, dbSeeChanges)
ClientSTR = "SELECT T1Companies.CompanyName " & _
"FROM T1Companies INNER JOIN T1Jobsites ON T1Companies.CompanyID = T1Jobsites.CompanyId " & _
"WHERE (((T1Jobsites.JobsiteID)=1))"
'ClientSTR = "SELECT T1Companies.CompanyName FROM T1Companies INNER JOIN T1Jobsites ON T1Companies.CompanyID = T1Jobsites.CompanyID" & _
" WHERE T1JobsitesID = 1" '& Form_LEM.TxtJobsiteID
Set RsClient = db.OpenRecordset(ClientSTR, dbOpenSnapshot, dbSeeChanges)
Set xlapp = CreateObject("excel.application")
Set wb = xlapp.Workbooks.Open("C:\Users\coc33713\Desktop\VISION - EXCEL FILES\VISIONCOUNT.xlsm")
Set ws = xlapp.Worksheets("CountSheet")
xlapp.Visible = True
'Tried this second after reading another forum
'the comments Recordset will be the actual values used, but I can't get the String "TEST" to work
wb.ws.Range("Client").Value = "TEST" 'RsClient!CompanyName
'Tried this way first
xlapp.ws.Range("'SiteName'").Value = "Test" 'RsJobsite!JobsiteNickName"
xlapp.ws.Range(Date).Value = "Test" 'Form_LEM.TxtDate
xlapp.ws.Range(ProjectName).Value = "Test" 'Form_LEM.TxtPlant
xlapp.ws.Range(ScaffoldID).Value = "Test" 'Form_LEM.cboScaffnum.Value
xlapp.ws.Range(ScaffoldNumber).Value = "Test" 'Form_LEM.cboScaffnum.Column(1)
Set xlapp = Nothing
Set wb = Nothing
Set ws = Nothing
Set RsClient = Nothing
Set RsJobsite = Nothing
Set db = Nothing
End Sub
As a Sidenote this is not a form it is just spreadsheet
Thank you everyone!
Use
ws.Range("Client").Value = "Test"
Or
Dim sName as String
sName = "Client"
ws.Range(sName).Value = "Test"
Reason being is that you have the ws object set already, so there is no need to assign parentage to it again. In fact, trying to do so will break syntax rules.
FWIW (not your issue - that is solved by Scott's answer): Note that
Set ws = xlapp.Worksheets("CountSheet")
should be
Set ws = wb.Worksheets("CountSheet").
Using xlapp.Worksheets("CountSheet")
is effectively xlApp.ActiveWorkbook.Worksheets("CountSheet") which might be (and probably is) xlApp.Workbooks("VISION - EXCEL FILES\VISIONCOUNT.xlsm").Worksheets("CountSheet") but it is better to do it correctly rather than leave it to chance.
Thank you guys!
This should do what you want.
Sub DAOFromExcelToAccess()
' exports data from the active worksheet to a table in an Access database
' this procedure must be edited before use
Dim db As Database, rs As Recordset, r As Long
Set db = OpenDatabase("C:\FolderName\DataBaseName.mdb")
' open the database
Set rs = db.OpenRecordset("TableName", dbOpenTable)
' get all records in a table
r = 3 ' the start row in the worksheet
Do While Len(Range("A" & r).Formula) > 0
' repeat until first empty cell in column A
With rs
.AddNew ' create a new record
' add values to each field in the record
.Fields("FieldName1") = Range("NamedRange1").Value
.Fields("FieldName2") = Range("NamedRange2").Value
.Fields("FieldNameN") = Range("NamedRangeN").Value
' add more fields if necessary...
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop
rs.Close
Set rs = Nothing
db.Close
Set db = Nothing
End Sub
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