Access ADO Excel and OLE Objects!


R

Read Only Member

Hi,

I have written a script to access data on an excel spreadsheet from
MSAccess... the script works when I run it on single sheets. However,
i get an inconsitent error (type Mismatch) when i run it against a
batch of sheets.

I think its something to do with excel not refreshing quick enough??

Is there a way of forcing it to refresh?? or just a better way of
doing it ??


Option Compare Database

Dim objXLS As Object
Dim objXLSwb As Object
Dim objXLSsh As Object



Private Sub FileSelect_Click()

Dim fileName As String

With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select Spreadsheet to Extract Data"
.Filters.Add "Excel", "*.xls", 1

' if user selects file then set filename
If .Show = -1 Then
fileName = .SelectedItems(1)
Else
Exit Sub
End If
End With

'Selected File
Me.SelectedFile.Value = fileName
'Update Selected Files List
Me.FilesAdded.AddItem fileName



End Sub

Private Sub Form_Close()
On Error Resume Next

If Not objXLS Is Nothing Then
'Close excel
objXLS.Close
Set objXLS = Nothing
End If

End Sub

Private Sub Form_Load()

Me.SelectedFile = Null

End Sub

Private Sub GetData_Click()

'When multiple selects will need to iterate through ItemsSelected
Collection
':: See getsheet_click ::

Dim rs As New ADODB.Recordset
Dim con As New ADODB.Connection

Dim sqlTextRs As String
Dim sqlTextUpd As String
Dim strDataVal As String
Dim strFileName As String
Dim strSheetName As String
Dim intTemplateID As Integer

'Select data Rows and Columns relevant
sqlTextRs = "SELECT tbl_SYS_Import_Template_Domains.TemplateID,
tbl_SYS_Import_Template_Domains.Col,
tbl_SYS_Import_Template_Domains.Row " & _
"FROM tbl_SYS_Import_Template_Domains " & _
"GROUP BY tbl_SYS_Import_Template_Domains.TemplateID,
tbl_SYS_Import_Template_Domains.Col,
tbl_SYS_Import_Template_Domains.Row " & _
"HAVING (((tbl_SYS_Import_Template_Domains.TemplateID)=" &
Me.SelectedTemplate.Column(0) & "));"

'Set warnings off
DoCmd.SetWarnings False

'clear processing pane
Me.ProcessFileCurrent = ""
Me.ProcessFileDone.RowSource = ""
Me.ProcessSheetCurrent = ""
Me.ProcessSheetDone.RowSource = ""

DoCmd.Hourglass True

'Set Connection
Set con = CurrentProject.Connection

'Set Template ID
intTemplateID = Me.SelectedTemplate.Column(0)

'Set File Name
strFileName = Me.FilesAdded.ItemData(0)
'Update Currently Processing file
Me.ProcessFileCurrent = strFileName

'Open Recordset
rs.Open sqlTextRs, con, adOpenForwardOnly
If rs.BOF = True And rs.EOF = True Then GoTo NODATA

'Start looping through Selected Sheets
For Each Item In Me.SelectedSheets.ItemsSelected

'Set Sheet Name
strSheetName = Me.SelectedSheets.ItemData(Item)
'Update currently processing sheet
Me.ProcessSheetCurrent = strSheetName


'Select relevant worksheet
With objXLS.Worksheets(strSheetName)

'Ensure beginning of recordset
rs.MoveFirst

'Initiate Loop
Do While Not rs.EOF

'Get cell value
strDataVal = .Cells(rs.Fields("Row"), rs.Fields
("Col")).Value

'build query for each cell recursion
sqlTextUpd = "INSERT INTO tbl_SYS_Import_Data " & _
"( FilePath, SheetName, TemplateID, Col,
Row, DataValue ) " & _
" SELECT " & _
"'" & strFileName & "', " & _
"'" & strSheetName & "', " & _
"" & intTemplateID & ", " & _
"" & rs.Fields("Col") & ", " & _
"" & rs.Fields("Row") & ", " & _
"'" & strDataVal & "';"

'add data to values table
DoCmd.RunSQL sqlTextUpd

rs.MoveNext

Loop

End With

'Update Processing sheet
Me.ProcessSheetCurrent = ""
'Update Processed Sheets List
Me.ProcessSheetDone.AddItem (strSheetName)
Me.ProcessSheetDone.Selected(Me.ProcessSheetDone.ListCount -
1) = True

Next

'Update Processing File
Me.ProcessFileCurrent = ""
'Update Processed File List
Me.ProcessFileDone.AddItem (strFileName)
Me.ProcessFileDone.Selected(Me.ProcessFileDone.ListCount - 1) =
True

NODATA:
DoCmd.Hourglass False
MsgBox "Done"

'Set warnings true
DoCmd.SetWarnings True

rs.Close
Set rs = Nothing

con.Close
Set con = Nothing

End Sub

Private Sub GetSheets_Click()

'Declare Vars
Dim objXLSws As Variant

Set objXLS = Nothing
'When multiple selects will need to iterate through ItemsSelected
Collection
':: See getdata_click ::
Set objXLS = GetObject(Me.FilesAdded.ItemData(0))
Set objXLSwb = objXLS.Application.ActiveWorkbook

objXLS.Application.Visible = False
objXLS.Parent.Windows(1).Visible = False

Set objXLSws = objXLS.Worksheets

For Each Worksheet In objXLSws

Me.SelectedSheets.AddItem (Worksheet.Name)
Me.SelectedSheets.Selected(Me.SelectedSheets.ListCount - 1) =
True

Next

End Sub

Private Sub RecreateData_Click()

Dim folderPath As String

Dim rs As New ADODB.Recordset
Dim con As New ADODB.Connection

Dim sqlTextRs As String
Dim sqlTextUpd As String
Dim strDataVal As String
Dim strFileName As String
Dim strSheetName As String
Dim intTemplateID As Integer
Dim intCount As Integer

'When multiple selects will need to iterate through ItemsSelected
Collection
':: See getsheet_click ::

'clear processing pane
Me.ProcessFileCurrent = ""
Me.ProcessFileDone.RowSource = ""
Me.ProcessSheetCurrent = ""
Me.ProcessSheetDone.RowSource = ""

DoCmd.Hourglass True

'Set Connection
Set con = CurrentProject.Connection

'Set Template ID
intTemplateID = Me.SelectedTemplate.Column(0)

'Set File Name
strFileName = Me.FilesAdded.ItemData(0)
'Update Currently Processing file
Me.ProcessFileCurrent = strFileName

'Set warnings off
DoCmd.SetWarnings False

' Create new Spreadhseet
Set objXLS = CreateObject("Excel.Application")
objXLS.Workbooks.Add
Set objXLSwb = objXLS.Workbooks

' remove any auto-generated worksheets
' For Each Worksheet In objXLS.Worksheets
' Worksheet.Delete
' Next


'Start looping through Selected Sheets (add in reverse order)
For intCount = (Me.SelectedSheets.ItemsSelected.Count - 1) To 0
Step -1

'Set Sheet Name
strSheetName = Me.SelectedSheets.ItemData(intCount)
'Update currently processing sheet
Me.ProcessSheetCurrent = strSheetName

'Select data Rows and Columns relevant
sqlTextRs = "SELECT tbl_SYS_Import_Data.FilePath,
tbl_SYS_Import_Data.SheetName, tbl_SYS_Import_Data.TemplateID,
tbl_SYS_Import_Data.Col, tbl_SYS_Import_Data.Row,
tbl_SYS_Import_Data.DataValue " & _
"FROM tbl_SYS_Import_Data " & _
"WHERE (((tbl_SYS_Import_Data.FilePath)='" &
strFileName & "') AND " & _
"((tbl_SYS_Import_Data.SheetName)='" &
strSheetName & "') AND " & _
"((tbl_SYS_Import_Data.TemplateID)=" &
intTemplateID & "));"

'Open Recordset
rs.Open sqlTextRs, con, adOpenForwardOnly
If rs.BOF = True And rs.EOF = True Then GoTo TONEXT

'Add Sheet
Set objXLSsh = objXLS.Worksheets.Add
objXLSsh.Name = strSheetName

'Select relevant worksheet
With objXLS.Worksheets(strSheetName)

'Ensure beginning of recordset
rs.MoveFirst

'Initiate Loop
Do While Not rs.EOF

'Set cell value
.Cells(rs.Fields("Row"), rs.Fields("Col")).Value =
rs.Fields("DataValue")

rs.MoveNext

Loop

End With

'Update Processing sheet
Me.ProcessSheetCurrent = ""
'Update Processed Sheets List
Me.ProcessSheetDone.AddItem (strSheetName)
Me.ProcessSheetDone.Selected(Me.ProcessSheetDone.ListCount -
1) = True

TONEXT:
rs.Close
Set rs = Nothing

Next

'Update Processing File
Me.ProcessFileCurrent = ""
'Update Processed File List
Me.ProcessFileDone.AddItem (strFileName)
Me.ProcessFileDone.Selected(Me.ProcessFileDone.ListCount - 1) =
True

' Delete auto "Sheet1/2/3"
objXLS.Worksheets("Sheet1").Delete
objXLS.Worksheets("Sheet2").Delete
objXLS.Worksheets("Sheet3").Delete

DoCmd.Hourglass False

objXLS.Save

MsgBox "Done"

'Set warnings true
DoCmd.SetWarnings True

Set rs = Nothing

con.Close
Set con = Nothing

End Sub

Private Sub SelectedTemplate_Change()

'Set Desc Values

'Set Dataset Name
If Me.SelectedTemplate.Column(2) = "" Or IsNull
(Me.SelectedTemplate.Column(2)) Then
Me.DatasetName = "NONE"
Else
Me.DatasetName = Me.SelectedTemplate.Column(2)
End If

'Set File Domain
If Me.SelectedTemplate.Column(3) = "" Or IsNull
(Me.SelectedTemplate.Column(3)) Then
Me.FileDomain = "NONE"
Else
Me.FileDomain = Me.SelectedTemplate.Column(3)
End If

'Set Sheet Domain
If Me.SelectedTemplate.Column(4) = "" Or IsNull
(Me.SelectedTemplate.Column(4)) Then
Me.SheetDomain = "NONE"
Else
Me.SheetDomain = Me.SelectedTemplate.Column(4)
End If



End Sub
 
Ad

Advertisements

S

Stefan Hoffmann

hi,
I think its something to do with excel not refreshing quick enough??
Maybe, but your code needs some refactoring in the first place. Separate
GUI code from the import logic code.
Is there a way of forcing it to refresh?? or just a better way of
doing it ??
E.g. introduce a method like

Private Sub ImportData(ASheet As Object)
' Import data from given sheet (Excel.Worksheet).
End Sub

Then you can easily loop over your collections.
i run it against a batch of sheets
There is no such think like a built-in batch of sheets. What do you mean
exactly?
Option Compare Database

Dim objXLS As Object
Dim objXLSwb As Object
Dim objXLSsh As Object
Here is an Option Explicit missing...


mfG
--> stefan <--
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top