Limited on number of import files

J

jnnvac

New member
Local time
Yesterday, 19:26
Joined
Jan 6, 2011
Messages
7
Hello everyone, i have an access database which i use to import data from multiple excel files into 3 different tables. However, i am limited on the number of files i can import without getting the msg "("The current file " & currentExcelFile & " is not in Excel or Lotus format and will be skipped.") by the way this msg is part of my code, but the files being iimported are excel files. Right now i can only select 36 files to import at a time and not get the msg. Below is part of the code relavent to this question: Thanks for any input.

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
 
Do you import the files one by one? Have you tried closing or clearing the variables that point to the excel files before you open the next file?
 
right now i can select all the files i want imported but after the 36th file i get the msg and it stops importing. so basically i can do 36 at a time.
 
So how do you select them? Did you build something to view and select these files? Wheres your code that performs the import? Is it a loop? Do the files get close or unloaded after the import? You're using VBA to do the import, right?
 
Here is the code to select the files, yes it does loop through all the files and closes each one after each import.

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
 
I don't see any import code, or anything that actually opens or closes the file for that matter. It appears you are getting a handle to the application. Are you telling the Excel application to load or open *.xls? I'm think it's possible that Excel does have a limit as to how many files it allows you to have open at one time.
 
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.
 
Have you tested to make sure that your file selection box is actually handing back more than 36 files?

I would test it in this code:
Code: 
'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
 
1. Don't create an Excel Application object for each file. Just create ONE at the start and then OPEN the applicable file if it is the correct file type.

2. You have code which is not tied to the Excel Object which then opens up a hidden instance of Excel and which then will cause you problems (which I think is your major problem). You should read this from my website (the Microsoft Access Team also incuded it on their blog).

And then go fix wherever you have these in use:
currentCell
columnACell
curDateCell
curRadioCell

as those are likely your major problem as they aren't tied into the Excel Application Object.
 
jnnvac said:
yes, i have this in the code.
Click to expand...

Okay, I missed where you tied it to the xlSheet object. But my comment about creating ONE xlApp and then just close the workbook and open the next workbook is better than having it try to blow away the xlAPP each time. Reuse your objects - don't make new ones each time.
 
hk1 said:
Have you tested to make sure that your file selection box is actually handing back more than 36 files?

I would test it in this code:
Code: 
'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
Click to expand...



yes, i have this in the code.
 
You must log in or register to reply here.

Similar threads

Gasman
Solved Open Excel workbook, but have WorkBook_Open code run
Replies
19
Views
984
Gasman
Gasman
N
Solved Failing To Save Imported Data from the internet in Ms Access
Replies
6
Views
697
nector
N
oxicottin
Solved Import from excel and delete unwanted data
Replies
14
Views
1,063
oxicottin
oxicottin
K
How can I add this code to the storage location of my file before scanning and then convert it to a PDF file?
2
Replies
25
Views
1,708
The_Doc_Man
The_Doc_Man
N
Solved Mass Importing Txt Files
Replies
14
Views
1,479
ebs17
E

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom