Hello,
I am trying to import multiple ranges into Access 2003 from a single Excel 2003 worksheet. The ranges all go to different tables with Access.
I can import a single range with no problem at all, but when I try and specify a second range all I get is the second range and not the first.
How do I import the addiional ranges?
Can anyone help me with this please?
Thanks,
I am trying to import multiple ranges into Access 2003 from a single Excel 2003 worksheet. The ranges all go to different tables with Access.
I can import a single range with no problem at all, but when I try and specify a second range all I get is the second range and not the first.
How do I import the addiional ranges?
Can anyone help me with this please?
Thanks,
Code:
Private Sub Command0_Click()
EmptyTables
Dim pPathname As String
pPathname = "\\cat\kieranm\BudgetTesting\2012\"
FilesInFolder (pPathname)
End Sub
Sub EmptyTables()
Dim db As Database
Set db = CurrentDb
DoCmd.SetWarnings False
db.Execute "DELETE * FROM [Summary_2011_Forecast]"
db.Execute "DELETE * FROM [Summary_2012_Budget]"
DoCmd.SetWarnings True
' Delete tables beginning _Import
For I = 0 To db.TableDefs.Count - 1
If Left(db.TableDefs(I).Name, 7) = "_Import" Then
db.Execute "DROP TABLE " & db.TableDefs(I).Name
End If
Next
Set db = Nothing
End Sub
Sub FilesInFolder(SourceFolderName As String)
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim pTablename As String
Dim pFilename As String
Dim pRange As String
Dim aTablename(1 To 10000) As String
Dim aFilename(1 To 10000) As String
Dim aRange(1 To 10000) As String
Dim sheetcount As Integer
sheetcount = 0
[Forms]![Budgets]![TransferCount].Value = Str(0)
Dim Summcount As Integer
Summcount = 0
Dim Inccount As Integer
Inccount = 0
Dim Salcount As Integer
Salcount = 0
Dim Opccount As Integer
Opccount = 0
Dim Ovccount As Integer
Ovccount = 0
Dim PNAcount As Integer
PNAcount = 0
[Forms]![Budgets]![Summary].Value = Str(Summcount)
[Forms]![Budgets]![Income].Value = Str(Inccount)
[Forms]![Budgets]![Salary].Value = Str(Salcount)
[Forms]![Budgets]![OpCost].Value = Str(Opccount)
[Forms]![Budgets]![OvCost].Value = Str(Ovccount)
[Forms]![Budgets]![PNA].Value = Str(PNAcount)
[Forms]![Budgets]![Total].Value = Str(sheetcount)
Me.Repaint
Dim LogFileName As String
LogFileName = SourceFolderName & "log.txt"
Dim FileNum As Integer
FileNum = FreeFile ' next file number
Open LogFileName For Output As #FileNum
Set xlApp = CreateObject("Excel.Application")
'Dim r As Long
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
[Forms]![Budgets]![Activity].Value = "Collecting Sheets"
For Each FileItem In SourceFolder.Files
If Right(FileItem.Name, 3) = "xls" Then
Print #FileNum, "XLS File:" & FileItem.Name
Set xlBook = xlApp.Workbooks.Open(FileItem.Path)
For Each tWS In xlBook.Worksheets
pTablename = ""
pFilename = ""
pRange = ""
If tWS.Name = "Summary" Then
pTablename = "Summary_Totals"
pFilename = SourceFolderName & FileItem.Name
pRange = tWS.Name & "!C10:O16"
Summcount = Summcount + 1
End If
If tWS.Name = "Summary" Then
pTablename = "Summary_2011_Forecast"
pFilename = SourceFolderName & FileItem.Name
pRange = tWS.Name & "!A21:G25"
Summcount = Summcount + 1
End If
If pTablename <> "" Then
Print #FileNum, "Worksheet:" & tWS.Name
sheetcount = sheetcount + 1
aTablename(sheetcount) = pTablename
aFilename(sheetcount) = pFilename
aRange(sheetcount) = pRange
[Forms]![Budgets]![CurrentFile].Value = pFilename
[Forms]![Budgets]![CurrentSheet].Value = tWS.Name
[Forms]![Budgets]![Summary].Value = Str(Summcount)
[Forms]![Budgets]![Income].Value = Str(Inccount)
[Forms]![Budgets]![Salary].Value = Str(Salcount)
[Forms]![Budgets]![OpCost].Value = Str(Opccount)
[Forms]![Budgets]![OvCost].Value = Str(Ovccount)
[Forms]![Budgets]![PNA].Value = Str(PNAcount)
[Forms]![Budgets]![Total].Value = Str(sheetcount)
Me.Repaint
End If
Next tWS
xlBook.Close False
End If
Next FileItem
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
Close #FileNum
xlApp.Quit
' Now transferspreadsheet for all the entries in the array
If sheetcount > 0 Then
[Forms]![Budgets]![Activity].Value = "Transferring Sheets to Database"
[Forms]![Budgets]![ProgressBar9].Max = sheetcount
Screen.MousePointer = 11
End If
For I = 1 To sheetcount
[Forms]![Budgets]![CurrentFile].Value = aFilename(I)
[Forms]![Budgets]![CurrentSheet].Value = aRange(I)
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8, aTablename(I), aFilename(I), No, aRange(I)
[Forms]![Budgets]![ProgressBar9].Value = I
[Forms]![Budgets]![TransferCount].Value = Str(I)
Me.Repaint
Next
Screen.MousePointer = 0
[Forms]![Budgets]![Activity].Value = "Transfer Completed"
End Sub
Private Sub Command32_Click()
End Sub
Private Sub Exit_Click()
On Error GoTo Err_Exit_Click
DoCmd.Close
Exit_Exit_Click:
Exit Sub
Err_Exit_Click:
MsgBox Err.Description
Resume Exit_Exit_Click
End Sub