the way it work is when i go to import, i get the windows dialog box to select the files to import. then vba opens each file not at the same time but individually, imports the information and then closes that files and moves on to the next one. but for some reason when i select mora than 36 files to import it does not recognize the 37th file as an excel file give me the error msg and stops importing.
There are 3 modules being used.
Module 1:
Function SelectProgramFiles()
Dim excelFiles As String
Dim answer As Integer
Dim MyMsg As String
Dim strDriveProj As String
Dim strPathProj As String
Dim strFileNameProj As String
Dim strExtProj As String
Dim MyNumber As Integer
Dim currentExcelFile As String
Dim tabPos As Long
Dim lastFile As Integer
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim currentCell As Object
Dim columnACell As Object
Dim curDateCell As Object
Dim curRadioCell As Object
Dim filePath As String
Dim count As Long
Dim datetest As Date
Dim db As Database
Dim rstProgram As Recordset
Dim rstCriteria As Recordset
Dim rstTier As Recordset
Dim TSID As Long
Dim ImportDate As String
Dim x As Long
Dim TypeCode As String
Dim i As Integer
Dim cell As Range
' Call the find file wizard to find the project.
excelFiles = FindFileLocation("C:\TS Program Setup\Program Templates", "Select The Program file(s)")
' This shows how to split the path and file name
'adhSplitPath newProject, strDriveProj, strPathProj, strFileNameProj, strExtProj
lastFile = 0
If VarType(excelFiles) < 2 Or excelFiles = "" Then
' Print no files selected for import
MsgBox ("No Excel or Lotus files were selected for import.")
Else
'Find the position of the first tab.
tabPos = InStr(1, excelFiles, Chr(9))
'If no tabs then only one file exists
If tabPos = 0 Then
lastFile = 1
tabPos = Len(excelFiles) + 1
End If
Set db = CurrentDb()
Set rstProgram = db.OpenRecordset("Program", dbOpenDynaset)
Set rstCriteria = db.OpenRecordset("CriteriaImport", dbOpenDynaset)
Set rstTier = db.OpenRecordset("TierImport", dbOpenDynaset)
'Do until the last file is imported
Do While tabPos > 0 Or lastFile = 1
currentExcelFile = Mid(excelFiles, 1, tabPos - 1)
excelFiles = Mid(excelFiles, tabPos + 1, Len(excelFiles))
'If not an Excel or Lotus file skip it.
If Not (Right(currentExcelFile, 3) = "xls" Or Right(currentExcelFile, 3) = "wk4") Then
' Print no files selected for import
MsgBox ("The current file " & currentExcelFile & " is not in Excel or Lotus format and will be skipped.")
Else
'Open a new Excel App
Set xlApp = CreateObject("Excel.Application") 'GetObject(, "Excel.Application")
'Set xlBook = xlApp.Workbooks.Open("c:\apps\heps\itemlist.xls")
xlApp.Visible = True
'Set the current workbook and sheet as active
Set xlBook = xlApp.Workbooks.Open(currentExcelFile)
' Set xlBook = xlApp.Workbooks.Add("j:\a\oms\" & radioFileName & ".xls")
Set xlSheet = xlBook.ActiveSheet
xlSheet.Activate
'**********************************************************************************************************
Set currentCell = xlSheet.Range("C5")
With rstProgram
.AddNew
!TypeCode = "01"
TSID = .Fields("TSID")
.Fields("ImportDate") = Date
!EnrollYear = xlSheet.Range("C3")
!PgmNbr = xlSheet.Range("C5")
!PgmDesc = xlSheet.Range("C6")
!ApexDesc = xlSheet.Range("J6")
!PgmTypeCode = xlSheet.Range("C9")
!UserID = xlSheet.Range("F3")
!PerfOption = xlSheet.Range("J2")
!FundAction = xlSheet.Range("J3")
!SaleType = xlSheet.Range("C10")
!PgmCategory = xlSheet.Range("C11")
!RptCategory = xlSheet.Range("C12")
!PgmType = xlSheet.Range("C13")
!AnnualFlg = xlSheet.Range("C14")
!EnrlPct = xlSheet.Range("C15")
!SharedFlg = xlSheet.Range("C16")
!SaleBasis = xlSheet.Range("C17")
!MeasureBasis = xlSheet.Range("C18")
!PayVendor = xlSheet.Range("C19")
!FundFlg = xlSheet.Range("C20")
!CheckMin = xlSheet.Range("C21")
!CmplcReq = xlSheet.Range("C22")
!GeoTable = xlSheet.Range("C24")
!BegDateYear = xlSheet.Range("I11")
!BegDatePeriod = xlSheet.Range("J11")
!BegDateWeek = xlSheet.Range("K11")
!EndDateYear = xlSheet.Range("L11")
!EndDatePeriod = xlSheet.Range("M11")
!EndDateWeek = xlSheet.Range("N11")
.Update
End With
'**********************************************************************************************************
For i = 30 To 184 Step 14
Set currentCell = xlSheet.Range(CStr("B" & i))
If (currentCell.Offset(x, 0)) <> 0 Then
With rstCriteria
.AddNew
!TypeCode = "02"
!TSID = TSID
!PgmNbr = xlSheet.Range("C5")
!EndDateYear = xlSheet.Range("L11")
!CriteriaSeq = currentCell.Offset(x, -1)
!CriteriaType = currentCell.Offset(x, 0)
!CalcBasis = currentCell.Offset(x, 1)
!BaseBegDateYear = currentCell.Offset(x, 2)
!BaseBegDatePeriod = currentCell.Offset(x, 3)
!BaseBegDateWeek = currentCell.Offset(x, 4)
!BaseEndDateYear = currentCell.Offset(x, 5)
!BaseEndDatePeriod = currentCell.Offset(x, 6)
!BaseEndDateWeek = currentCell.Offset(x, 7)
!CurrBegDateYear = currentCell.Offset(x, 8)
!CurrBegDatePeriod = currentCell.Offset(x, 9)
!CurrBegDateWeek = currentCell.Offset(x, 10)
!CurrEndDateYear = currentCell.Offset(x, 11)
!CurrEndDatePeriod = currentCell.Offset(x, 12)
!CurrEndDateWeek = currentCell.Offset(x, 13)
!ExclStor = currentCell.Offset(x, 14)
!InitPayment = currentCell.Offset(x, 15)
!TotCalc = currentCell.Offset(x, 16)
!ItemCode = currentCell.Offset(x, 17)
!PaymntRate = currentCell.Offset(x, 18)
!PaymntAmnt = currentCell.Offset(x, 19)
!HurdleRate = currentCell.Offset(x, 20)
.Update
End With
End If
Next i
'***************************************************************************************************************
Set currentCell = xlSheet.Range("A32")
With rstTier
If (currentCell.Offset(x, 1)) <> 0 Then
.AddNew
!TypeCode = "03"
!TSID = TSID
!PgmNbr = xlSheet.Range("C5")
!EndDateYear = xlSheet.Range("L11")
!CriteriaSeq = xlSheet.Range("A30")
!TierNbr = currentCell.Offset(x, 1)
!PayRate = currentCell.Offset(x, 3)
!PayAmount = currentCell.Offset(x, 6)
!AccumMethod = currentCell.Offset(x, 11)
!TierMin = currentCell.Offset(x, 14)
!TierMax = currentCell.Offset(x, 17)
.Update
End If
Set currentCell = xlSheet.Range("A33")
If (currentCell.Offset(x, 1)) <> 0 Then
.AddNew
!TypeCode = "03"
!TSID = TSID
!PgmNbr = xlSheet.Range("C5")
!EndDateYear = xlSheet.Range("L11")
!CriteriaSeq = xlSheet.Range("A30")
!TierNbr = currentCell.Offset(x, 1)
!PayRate = currentCell.Offset(x, 3)
!PayAmount = currentCell.Offset(x, 6)
!AccumMethod = currentCell.Offset(x, 11)
!TierMin = currentCell.Offset(x, 14)
!TierMax = currentCell.Offset(x, 17)
.Update
End If
Set currentCell = xlSheet.Range("A34")
If (currentCell.Offset(x, 1)) <> 0 Then
.AddNew
!TypeCode = "03"
!TSID = TSID
!PgmNbr = xlSheet.Range("C5")
!EndDateYear = xlSheet.Range("L11")
!CriteriaSeq = xlSheet.Range("A30")
!TierNbr = currentCell.Offset(x, 1)
!PayRate = currentCell.Offset(x, 3)
!PayAmount = currentCell.Offset(x, 6)
!AccumMethod = currentCell.Offset(x, 11)
!TierMin = currentCell.Offset(x, 14)
!TierMax = currentCell.Offset(x, 17)
.Update
End If
Set currentCell = xlSheet.Range("A35")
If (currentCell.Offset(x, 1)) <> 0 Then
.AddNew
!TypeCode = "03"
!TSID = TSID
!PgmNbr = xlSheet.Range("C5")
!EndDateYear = xlSheet.Range("L11")
!CriteriaSeq = xlSheet.Range("A30")
!TierNbr = currentCell.Offset(x, 1)
!PayRate = currentCell.Offset(x, 3)
!PayAmount = currentCell.Offset(x, 6)
!AccumMethod = currentCell.Offset(x, 11)
!TierMin = currentCell.Offset(x, 14)
!TierMax = currentCell.Offset(x, 17)
.Update
End If
Set currentCell = xlSheet.Range("A36")
If (currentCell.Offset(x, 1)) <> 0 Then
.AddNew
!TypeCode = "03"
!TSID = TSID
!PgmNbr = xlSheet.Range("C5")
!EndDateYear = xlSheet.Range("L11")
!CriteriaSeq = xlSheet.Range("A30")
!TierNbr = currentCell.Offset(x, 1)
!PayRate = currentCell.Offset(x, 3)
!PayAmount = currentCell.Offset(x, 6)
!AccumMethod = currentCell.Offset(x, 11)
!TierMin = currentCell.Offset(x, 14)
!TierMax = currentCell.Offset(x, 17)
.Update
End If
Set currentCell = xlSheet.Range("A37")
If (currentCell.Offset(x, 1)) <> 0 Then
.AddNew
!TypeCode = "03"
!TSID = TSID
!PgmNbr = xlSheet.Range("C5")
!EndDateYear = xlSheet.Range("L11")
!CriteriaSeq = xlSheet.Range("A30")
!TierNbr = currentCell.Offset(x, 1)
!PayRate = currentCell.Offset(x, 3)
!PayAmount = currentCell.Offset(x, 6)
!AccumMethod = currentCell.Offset(x, 11)
!TierMin = currentCell.Offset(x, 14)
!TierMax = currentCell.Offset(x, 17)
.Update
End If
Set currentCell = xlSheet.Range("A38")
If (currentCell.Offset(x, 1)) <> 0 Then
.AddNew
!TypeCode = "03"
!TSID = TSID
!PgmNbr = xlSheet.Range("C5")
!EndDateYear = xlSheet.Range("L11")
!CriteriaSeq = xlSheet.Range("A30")
!TierNbr = currentCell.Offset(x, 1)
!PayRate = currentCell.Offset(x, 3)
!PayAmount = currentCell.Offset(x, 6)
!AccumMethod = currentCell.Offset(x, 11)
!TierMin = currentCell.Offset(x, 14)
!TierMax = currentCell.Offset(x, 17)
.Update
End If
Set currentCell = xlSheet.Range("A39")
If (currentCell.Offset(x, 1)) <> 0 Then
.AddNew
!TypeCode = "03"
!TSID = TSID
!PgmNbr = xlSheet.Range("C5")
!EndDateYear = xlSheet.Range("L11")
!CriteriaSeq = xlSheet.Range("A30")
!TierNbr = currentCell.Offset(x, 1)
!PayRate = currentCell.Offset(x, 3)
!PayAmount = currentCell.Offset(x, 6)
!AccumMethod = currentCell.Offset(x, 11)
!TierMin = currentCell.Offset(x, 14)
!TierMax = currentCell.Offset(x, 17)
.Update
End If
End With
Set xlSheet = Nothing
Set xlBook = Nothing
xlApp.Quit
Set xlApp = Nothing
End If
tabPos = InStr(1, excelFiles, Chr(9))
If tabPos = 0 And lastFile = 0 Then
lastFile = 1
tabPos = Len(excelFiles) + 1
Else
lastFile = 0
End If
Loop
rstTier.Close
rstCriteria.Close
rstProgram.Close
db.Close
End If
MsgBox ("Program Templates Have Been Added To Access Tables")
End Function
****************************************************************
Module 2
Function FindFileLocation(initDir As String, header As String, Optional onlyFileName As String) As String
Dim gfni As adh_accOfficeGetFileNameInfo
FindNewFile:
If IsMissing(onlyFileName) Then onlyFileName = ""
With gfni
.hwndOwner = Application.hWndAccessApp
.strAppName = "Find Delete a Project"
.strDlgTitle = header
.strOpenTitle = "Select"
.strFile = onlyFileName
.strInitialDir = "C:\TS Program Setup\Program Templates\" 'initDir
.strFilter = "All Files (*.*)|Spreadsheets (*.xls,*.wk4)"
.lngFilterIndex = 1
.lngView = adhcGfniViewDetails
.lngFlags = adhcGfniNoChangeDir Or adhcGfniInitializeView Or adhcGfniAllowMultiSelect
End With
If adhOfficeGetFileName(gfni, True) = adhcAccErrSuccess Then
'MsgBox "You choose: " & Trim(gfni.strFile), vbOKOnly, "Find File"
FindFileLocation = Trim(gfni.strFile)
Else
'MsgBox "No file location provided, will now close."
FindFileLocation = ""
Exit Function
End If
End Function 'FindFileLocation() As String
**************************************************************
Module 3
Function adhOfficeGetFileName(gfni As adh_accOfficeGetFileNameInfo, _
ByVal fOpen As Integer) As Long
' Use the Office file selector common dialog
' exposed by Access.
' From Access 97 Developer's Handbook
' by Litwin, Getz, and Gilbert (Sybex)
' Copyright 1997. All rights reserved.
Dim lng As Long
With gfni
.strAppName = RTrim$(.strAppName) & vbNullChar
.strDlgTitle = RTrim$(.strDlgTitle) & vbNullChar
.strOpenTitle = RTrim$(.strOpenTitle) & vbNullChar
.strFile = RTrim$(.strFile) & vbNullChar
.strInitialDir = RTrim$(.strInitialDir) & vbNullChar
.strFilter = RTrim$(.strFilter) & vbNullChar
SysCmd acSysCmdClearHelpTopic
lng = adh_accOfficeGetFileName(gfni, fOpen)
.strAppName = RTrim$(adhTrimNull(.strAppName))
.strDlgTitle = RTrim$(adhTrimNull(.strDlgTitle))
.strOpenTitle = RTrim$(adhTrimNull(.strOpenTitle))
.strFile = RTrim$(adhTrimNull(.strFile))
.strInitialDir = RTrim$(adhTrimNull(.strInitialDir))
.strFilter = RTrim$(adhTrimNull(.strFilter))
End With
adhOfficeGetFileName = lng
End Function
Function adhTrimNull(strVal As String) As String
' Trim the end of a string, stopping at the first
' null character.
' From Access 97 Developer's Handbook
' by Litwin, Getz, and Gilbert (Sybex)
' Copyright 1997. All rights reserved.
Dim intPos As Integer
intPos = InStr(strVal, vbNullChar)
If intPos > 0 Then
adhTrimNull = Left$(strVal, intPos - 1)
Else
adhTrimNull = strVal
End If
End Function
Thanks for looking into this.