S
Steven M. Britton
I'm looking for some feedback with regard to taking some data from an Excel
Workbook we use to track info on and loading it into Access AS QUICKLY AS
possible. Once it's in Access I can do the rest, but I am sort of new at the
best method to automate the movement from Excel to Access. I kind of know
DAO and haven't used ADO - is ADO any faster with what I'm doing below.
I'm wanting to start a dialog and looking for resources. Anyones help
and/or suggestions will be great.
Public Sub btnMakeReport_Click()
On Error GoTo Error_Handling
Dim strPath As String
Dim xlsApp As Object
Dim End_Row As Long
Dim db As DAO.Database
Dim strSQL As String
Dim strCriteria1 As String
Dim strCriteria2 As String
Dim strMsg As String
Dim bWarn As Boolean
Dim intRcount As Integer
Dim intCount As Integer
Dim strWrapChar As String
'Check to see that Combo Boxes have Selections Made
If IsNull(Me.cmbQtr.Value) = True Then
bWarn = True
strMsg = strMsg & "You must select a Quarter." & vbCrLf
End If
If IsNull(Me.cmbYear.Value) = True Then
bWarn = True
strMsg = strMsg & "You must select a Year." & vbCrLf
End If
If bWarn = True Then
strMsg = strMsg & vbCrLf & "You must Retry"
MsgBox strMsg, vbOKOnly, "Warning"
Exit Sub
End If
Set db = CurrentDb()
'Read Combo Boxes and Set Criteria to Filter with Excel
Select Case Me.cmbQtr
Case Is = "Q1"
strCriteria1 = ">12/31/" & Me.cmbYear & " 23:59:59"
strCriteria2 = "<04/01/" & Me.cmbYear & " 00:00:01"
Case Is = "Q2"
strCriteria1 = ">03/31/" & Me.cmbYear & " 23:59:59"
strCriteria2 = "<07/01/" & Me.cmbYear & " 00:00:01"
Case Is = "Q3"
strCriteria1 = ">06/30/" & Me.cmbYear & " 23:59:59"
strCriteria2 = "<010/01/" & Me.cmbYear & " 00:00:01"
Case Is = "Q4"
strCriteria1 = ">09/30/" & Me.cmbYear & " 23:59:59"
strCriteria2 = "<01/01/" & Me.cmbYear + 1 & " 00:00:01"
End Select
'Opens Windows Dialog Module written by Ken Getz
strPath = GetOpenFileExcel
'If User Canels Quit Sub
If IsNull(strPath) = True Or strPath = "" Then
Exit Sub
Else
Set xlsApp = CreateObject("Excel.Application")
xlsApp.Visible = False
'Open Workbook as Read-Only
xlsApp.WorkBooks.Open strPath, UpdateLinks:=0, ReadOnly:=True
xlsApp.Sheets("Master BOM Sheet").Select
'Turn off filter if on.
If xlsApp.Sheets("Master BOM Sheet").FilterMode = True Then
xlsApp.ActiveSheet.ShowAllData
End If
'Set my filter based on Quarter requested.
xlsApp.Selection.AutoFilter Field:=3, Criteria1:=strCriteria1,
Operator:=1, Criteria2:=strCriteria2
End_Row = xlsApp.Cells(xlsApp.Rows.Count, 1).End(-4162).Row
xlsApp.Range(xlsApp.Cells(26, 1), xlsApp.Cells(End_Row,
38)).SpecialCells(12).Select
xlsApp.Selection.Copy
xlsApp.WorkBooks.Add
xlsApp.Selection.PasteSpecial Paste:=-4163
xlsApp.Application.CutCopyMode = False
'Replace Characters that will cause the APPEND Query to fail
On Error Resume Next
xlsApp.Selection.Replace What:="""", Replacement:="''", LookAt:=2,
SearchOrder:=1
xlsApp.Selection.Replace What:="#N/A", Replacement:="NA", LookAt:=2,
SearchOrder:=1
On Error GoTo Error_Handling
End_Row = xlsApp.Cells(xlsApp.Rows.Count, 1).End(-4162).Row
intRcount = 2
'Clear any old data
db.Execute "DELETE * FROM tblDMLifeCycle;"
Do
'Insert data into the table
strSQL = ""
strSQL = strSQL & "INSERT INTO tblDMLifeCycle"
strSQL = strSQL & " VALUES ("
For intCount = 1 To 38
Select Case intCount
Case Is = 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14,
15, 16, 17, 18, 19, 24, 29, 31, 37
strWrapChar = """"
strSQL = strSQL & strWrapChar &
xlsApp.Cells(intRcount, intCount) & strWrapChar
Case Else
strWrapChar = ""
If Trim(xlsApp.Cells(intRcount, intCount)) = "" Then
strSQL = strSQL & strWrapChar & 0 & strWrapChar
Else
strSQL = strSQL & strWrapChar &
xlsApp.Cells(intRcount, intCount) & strWrapChar
End If
End Select
If intCount <> 38 Then
strSQL = strSQL & ","
Else
strSQL = strSQL & ")"
End If
Next
db.Execute strSQL
intRcount = intRcount + 1
Loop Until intRcount > End_Row
Do While xlsApp.WorkBooks.Count > 0
xlsApp.WorkBooks(1).Close False 'close without saving
Loop
xlsApp.Quit
Set xlsApp = Nothing
End If
Error_Handling:
MsgBox Err.Description
Exit Sub
End Sub
Workbook we use to track info on and loading it into Access AS QUICKLY AS
possible. Once it's in Access I can do the rest, but I am sort of new at the
best method to automate the movement from Excel to Access. I kind of know
DAO and haven't used ADO - is ADO any faster with what I'm doing below.
I'm wanting to start a dialog and looking for resources. Anyones help
and/or suggestions will be great.
Public Sub btnMakeReport_Click()
On Error GoTo Error_Handling
Dim strPath As String
Dim xlsApp As Object
Dim End_Row As Long
Dim db As DAO.Database
Dim strSQL As String
Dim strCriteria1 As String
Dim strCriteria2 As String
Dim strMsg As String
Dim bWarn As Boolean
Dim intRcount As Integer
Dim intCount As Integer
Dim strWrapChar As String
'Check to see that Combo Boxes have Selections Made
If IsNull(Me.cmbQtr.Value) = True Then
bWarn = True
strMsg = strMsg & "You must select a Quarter." & vbCrLf
End If
If IsNull(Me.cmbYear.Value) = True Then
bWarn = True
strMsg = strMsg & "You must select a Year." & vbCrLf
End If
If bWarn = True Then
strMsg = strMsg & vbCrLf & "You must Retry"
MsgBox strMsg, vbOKOnly, "Warning"
Exit Sub
End If
Set db = CurrentDb()
'Read Combo Boxes and Set Criteria to Filter with Excel
Select Case Me.cmbQtr
Case Is = "Q1"
strCriteria1 = ">12/31/" & Me.cmbYear & " 23:59:59"
strCriteria2 = "<04/01/" & Me.cmbYear & " 00:00:01"
Case Is = "Q2"
strCriteria1 = ">03/31/" & Me.cmbYear & " 23:59:59"
strCriteria2 = "<07/01/" & Me.cmbYear & " 00:00:01"
Case Is = "Q3"
strCriteria1 = ">06/30/" & Me.cmbYear & " 23:59:59"
strCriteria2 = "<010/01/" & Me.cmbYear & " 00:00:01"
Case Is = "Q4"
strCriteria1 = ">09/30/" & Me.cmbYear & " 23:59:59"
strCriteria2 = "<01/01/" & Me.cmbYear + 1 & " 00:00:01"
End Select
'Opens Windows Dialog Module written by Ken Getz
strPath = GetOpenFileExcel
'If User Canels Quit Sub
If IsNull(strPath) = True Or strPath = "" Then
Exit Sub
Else
Set xlsApp = CreateObject("Excel.Application")
xlsApp.Visible = False
'Open Workbook as Read-Only
xlsApp.WorkBooks.Open strPath, UpdateLinks:=0, ReadOnly:=True
xlsApp.Sheets("Master BOM Sheet").Select
'Turn off filter if on.
If xlsApp.Sheets("Master BOM Sheet").FilterMode = True Then
xlsApp.ActiveSheet.ShowAllData
End If
'Set my filter based on Quarter requested.
xlsApp.Selection.AutoFilter Field:=3, Criteria1:=strCriteria1,
Operator:=1, Criteria2:=strCriteria2
End_Row = xlsApp.Cells(xlsApp.Rows.Count, 1).End(-4162).Row
xlsApp.Range(xlsApp.Cells(26, 1), xlsApp.Cells(End_Row,
38)).SpecialCells(12).Select
xlsApp.Selection.Copy
xlsApp.WorkBooks.Add
xlsApp.Selection.PasteSpecial Paste:=-4163
xlsApp.Application.CutCopyMode = False
'Replace Characters that will cause the APPEND Query to fail
On Error Resume Next
xlsApp.Selection.Replace What:="""", Replacement:="''", LookAt:=2,
SearchOrder:=1
xlsApp.Selection.Replace What:="#N/A", Replacement:="NA", LookAt:=2,
SearchOrder:=1
On Error GoTo Error_Handling
End_Row = xlsApp.Cells(xlsApp.Rows.Count, 1).End(-4162).Row
intRcount = 2
'Clear any old data
db.Execute "DELETE * FROM tblDMLifeCycle;"
Do
'Insert data into the table
strSQL = ""
strSQL = strSQL & "INSERT INTO tblDMLifeCycle"
strSQL = strSQL & " VALUES ("
For intCount = 1 To 38
Select Case intCount
Case Is = 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14,
15, 16, 17, 18, 19, 24, 29, 31, 37
strWrapChar = """"
strSQL = strSQL & strWrapChar &
xlsApp.Cells(intRcount, intCount) & strWrapChar
Case Else
strWrapChar = ""
If Trim(xlsApp.Cells(intRcount, intCount)) = "" Then
strSQL = strSQL & strWrapChar & 0 & strWrapChar
Else
strSQL = strSQL & strWrapChar &
xlsApp.Cells(intRcount, intCount) & strWrapChar
End If
End Select
If intCount <> 38 Then
strSQL = strSQL & ","
Else
strSQL = strSQL & ")"
End If
Next
db.Execute strSQL
intRcount = intRcount + 1
Loop Until intRcount > End_Row
Do While xlsApp.WorkBooks.Count > 0
xlsApp.WorkBooks(1).Close False 'close without saving
Loop
xlsApp.Quit
Set xlsApp = Nothing
End If
Error_Handling:
MsgBox Err.Description
Exit Sub
End Sub