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
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