Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Register Log in
  • Congratulations SkipVought on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Importing multiple ranges from a single worksheet

Status
Not open for further replies.
h20vrrq

h20vrrq

MIS
May 28, 2008
21
0
0
GB
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,

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
 
Sort by date Sort by votes
I should have mentioned that I am searching upto 300 workbooks in the same folder. Each workbook has a number of worksheets one of which is always called 'Summary'.

The other worksheets from all workbooks will also be imported.
 
Upvote 0 Downvote
How are ya h20vrrq . . .

Could you show your final code so others with the same problem can benefit?

[blue]Your Thoughts? . . .[/blue]

See Ya! . . . . . .

Be sure to see faq219-2884 [blue]Worthy Reading![/blue] [thumbsup2]
Also faq181-2886 [blue]Worthy Reading![/blue] [thumbsup2]
 
Upvote 0 Downvote
Hi,

The solution we came up with is below. Basically just added an index to only look at each range once.


Code: 
Option Compare Database

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_Totals]"
db.Execute "DELETE * FROM [Summary_2011_Forecast]"
db.Execute "DELETE * FROM [Summary_2012_Budget]"
db.Execute "DELETE * FROM [Summary_2012_Budget_FTEs]"
db.Execute "DELETE * FROM [Summary_Cap_Exp_2011_Forecast]"
db.Execute "DELETE * FROM [Summary_Cap_Exp_Carry_over_Proj_2012_Budget]"
db.Execute "DELETE * FROM [Income]"
db.Execute "DELETE * FROM [Salary]"
db.Execute "DELETE * FROM [Salary_Summary]"
db.Execute "DELETE * FROM [OpCost]"
db.Execute "DELETE * FROM [OvCost]"
db.Execute "DELETE * FROM [PNA_Activity_Description]"
db.Execute "DELETE * FROM [PNA_IE_Summary]"
db.Execute "DELETE * FROM [PNA_IE_Summary_FTEs]"
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(1 To 10000) As String
Dim pFilename(1 To 10000)  As String
Dim pRange(1 To 10000)  As String
[COLOR=red]Dim pIndex As Integer
Dim j As Integer
[/color]

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
        
        Dim k As Integer
        For k = 1 To 10000
           pTablename(k) = ""
           pFilename(k) = ""
           pRange(k) = ""
        Next k
        
        pIndex = 0

' --------------------------------------------------------------------

        If tWS.Name = "Summary" Then
            pIndex = pIndex + 1
            pTablename(pIndex) = "Summary_Totals"
            pFilename(pIndex) = SourceFolderName & FileItem.Name
            pRange(pIndex) = tWS.Name & "!C10:O16"
            Summcount = Summcount + 1
        End If
 
' --------------------------------------------------------------------

        If tWS.Name = "Summary" Then
            pIndex = pIndex + 1
            pTablename(pIndex) = "Summary_2011_Forecast"
            pFilename(pIndex) = SourceFolderName & FileItem.Name
            pRange(pIndex) = tWS.Name & "!A21:G25"
        End If
        
 ' --------------------------------------------------------------------
  
        If tWS.Name = "Summary" Then
            pIndex = pIndex + 1
            pTablename(pIndex) = "Summary_2012_Budget"
            pFilename(pIndex) = SourceFolderName & FileItem.Name
            pRange(pIndex) = tWS.Name & "!A29:O33"
        End If
        
' ---------------------------------------------------------------------
 
        If tWS.Name = "Summary" Then
            pIndex = pIndex + 1
            pTablename(pIndex) = "Summary_2012_Budget_FTEs"
            pFilename(pIndex) = SourceFolderName & FileItem.Name
            pRange(pIndex) = tWS.Name & "!A35:O35"
        End If
        
 ' --------------------------------------------------------------------
  
        If tWS.Name = "Summary" Then
            pIndex = pIndex + 1
            pTablename(pIndex) = "Summary_Cap_Exp_2011_Forecast"
            pFilename(pIndex) = SourceFolderName & FileItem.Name
            pRange(pIndex) = tWS.Name & "!A39:G39"
        End If
        
 ' --------------------------------------------------------------------
 
        If tWS.Name = "Summary" Then
            pIndex = pIndex + 1
            pTablename(pIndex) = "Summary_Cap_Exp_Carry_over_Proj_2012_Budget"
            pFilename(pIndex) = SourceFolderName & FileItem.Name
            pRange(pIndex) = tWS.Name & "!A43:O43"
        End If
        
 ' --------------------------------------------------------------------
 
        If tWS.Name = "Income" Then
            pIndex = pIndex + 1
            pTablename(pIndex) = "Income"
            pFilename(pIndex) = SourceFolderName & FileItem.Name
            pRange(pIndex) = tWS.Name & "!A3:U37"
            Inccount = Inccount + 1
        End If
        
 ' --------------------------------------------------------------------
  
        If tWS.Name = "Salary" Then
            pIndex = pIndex + 1
            pTablename(pIndex) = "Salary"
            pFilename(pIndex) = SourceFolderName & FileItem.Name
            pRange(pIndex) = tWS.Name & "!B5:AF31"
            Salcount = Salcount + 1
        End If
        
 ' --------------------------------------------------------------------
  
        If tWS.Name = "Salary" Then
            pIndex = pIndex + 1
            pTablename(pIndex) = "Salary_Summary"
            pFilename(pIndex) = SourceFolderName & FileItem.Name
            pRange(pIndex) = tWS.Name & "!S34:AF46"
        End If
        
 ' --------------------------------------------------------------------
  
        If tWS.Name = "Operational Cost" Then
            pIndex = pIndex + 1
            pTablename(pIndex) = "OpCost"
            pFilename(pIndex) = SourceFolderName & FileItem.Name
            pRange(pIndex) = tWS.Name & "!A3:U44"
            Opccount = Opccount + 1
        End If
        
 ' --------------------------------------------------------------------
  
        If tWS.Name = "Overhead Cost" Then
            pIndex = pIndex + 1
            pTablename(pIndex) = "OvCost"
            pFilename(pIndex) = SourceFolderName & FileItem.Name
            pRange(pIndex) = tWS.Name & "!A3:U44"
            Ovccount = Ovccount + 1
        End If
        
 ' --------------------------------------------------------------------
   
        If tWS.Name = "PNA" Then
            pIndex = pIndex + 1
            pTablename(pIndex) = "PNA_Activity_description"
            pFilename(pIndex) = SourceFolderName & FileItem.Name
            pRange(pIndex) = tWS.Name & "!D2:D2"
            PNAcount = PNAcount + 1
        End If
        
 ' --------------------------------------------------------------------
   
        If tWS.Name = "PNA" Then
            pIndex = pIndex + 1
            pTablename(pIndex) = "PNA_IE_Summary"
            pFilename(pIndex) = SourceFolderName & FileItem.Name
            pRange(pIndex) = tWS.Name & "!G10:S16"
            PNAcount = PNAcount + 1
        End If
        
 ' --------------------------------------------------------------------
   
        If tWS.Name = "PNA" Then
            pIndex = pIndex + 1
            pTablename(pIndex) = "PNA_IE_Summary_FTEs"
            pFilename(pIndex) = SourceFolderName & FileItem.Name
            pRange(pIndex) = tWS.Name & "!H18:S18"
            PNAcount = PNAcount + 1
        End If
        
 ' --------------------------------------------------------------------
 
         For j = 1 To pIndex
            If pTablename(j) <> "" Then
                Print #FileNum, "Worksheet:" & tWS.Name
                sheetcount = sheetcount + 1
                aTablename(sheetcount) = pTablename(j)
                aFilename(sheetcount) = pFilename(j)
                aRange(sheetcount) = pRange(j)
      
                   
        [Forms]![Budgets]![CurrentFile].Value = pFilename(j)
        [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 j
        
        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
 
Upvote 0 Downvote
Status
Not open for further replies.

Similar threads

Moss100
  • Locked
  • Question
Add multiple contacts to outlook - from access table
Replies
12
Views
137
Moss100
Moss100
JayRo71
  • Locked
  • Question
docmd.TransferText not importing a number field
Replies
1
Views
111
JayRo71
JayRo71
Moss100
  • Locked
  • Question
Remove everything including the comma from the last comma of a string. 1
Replies
10
Views
179
Andrzejek
Andrzejek
Viswa.R
  • Locked
  • Question
Dimension import from Autocad to Excel
Replies
0
Views
88
Viswa.R
Viswa.R
Moss100
  • Locked
  • Question
Convert Single Line Address to Multi Line Address 2
Replies
9
Views
100
Moss100
Moss100

Part and Inventory Search

Sponsor

Back
Top