Solved

MICROSOFT ACCESS 2007/Excel 2007

Posted on 2011-09-14
11
264 Views
Last Modified: 2012-05-12
I want to load multiple excel worksheets(5) into access table.  I only want certain excel ranges from each worksheet.   I found code to loop through the directory for the sheets but I am having problem with range properties in excel.  Here is what i have so far.

Public Function MYPREMLOAD()
    Dim strPath As String, strFolderPath As String
    Dim appExcel As Excel.Application
    Dim MyDB As DAO.Database, MyRS As DAO.Recordset
    Dim LastRow As Long
   
    DoCmd.SetWarnings False
    strsql = "Delete * From tblPolicyLoad;"
    DoCmd.RunSQL strsql
    DoCmd.SetWarnings True
 
    Set MyDB = CurrentDb()
   
    Set MyRS = MyDB.OpenRecordset("tblPolicyLoad", dbOpenDynaset)
     
   
    strFolderPath = "X:\Special Risk\miketesting\KARA\"
    strPath = "X:\Special Risk\miketesting\KARA\*.xls"
     
    strPath = Dir(strPath, vbNormal)
    Set appExcel = CreateObject("Excel.Application")
     
    Do While strPath <> ""
        appExcel.Workbooks.Open strFolderPath & strPath
        appExcel.Visible = True

       WHERE DO A PUT THE SHEETNAME I WANT TO REFERENCE?
       I ONLY WANT TO REFEERENCE THE FOLLOWING CELLS FROM EACH SHEET
       B10
       C10
       D10

        With MyRS
       

*****WHAT CODE GOES HERE





************END CODE
        End With
        strPath = Dir
    Loop
     
    appExcel.Quit
    Set appExcel = Nothing
    'appExcel.ActiveWorkbook.Close
    MyRS.Close
    Set MyRS = Nothing
0
Comment
Question by:centralmike
  • 6
  • 4
11 Comments
 
LVL 16

Expert Comment

by:carsRST
ID: 36537560
If you know the name of the sheet, you could do something like this within your code



Dim rng As Range
Set rng = Activeworkbook.sheets("...name of sheet...").Range("B10:D10")

'loop through range and pull out values
For i = 1 To rng.Columns.Count
    strValueFromRange = rng(i).Value 'gets the value certain spot in range
Next
0
 

Author Comment

by:centralmike
ID: 36537697
can you look at the entire code.  It code you sent me errors out at the following statement.
For i = 1 To rng.Columns.Count
.   Can you send me a copy the module with the changes you selected.  What if you have multiple ranges like B2 TO D2. Does the code handle this.  Thanks
0
 
LVL 16

Expert Comment

by:carsRST
ID: 36537748
>>  It code you sent me errors out at the following statement.

Assuming you know the name of the sheet, did you change it in this line of code?
Set rng = Activeworkbook.sheets("...YOUR sheet name...").Range("B10:D10")


>>What if you have multiple ranges like B2 TO D2
Same process as before.  Just change the Range selection, see line below
....Range("B10:D10")



>>  I ONLY WANT TO REFEERENCE THE FOLLOWING CELLS FROM EACH SHEET

See more sample code below.
'YOUR CODE
appExcel.Workbooks.Open strFolderPath & strPath
appExcel.Visible = True



Dim rng As Range
Dim sht As Worksheet

'loop through each sheet
For a = 1 To ActiveWorkbook.Sheets.Count

    With ActiveWorkbook.Sheets(a)
    
        'set range
        Set rng = Range("B10:D10")
        
        'get value from range
        For i = 1 To rng.Columns.Count
            strValueFromRange = rng(i).Value
            
            'execute SQL INSERT
        Next
        
        
        'set NEW range selection
        Set rng = Range("B2:D2")
        
        'get value from range
        For i = 1 To rng.Columns.Count
            strValueFromRange2 = rng(i).Value
            
            'execute SQL INSERT
        Next
        
    End With

Next a

Open in new window

0
 
LVL 16

Expert Comment

by:carsRST
ID: 36537755
With that last code, you do not need to know the name of each sheet.  It will loop through EVERY sheet on the just opened workbook and get the values from the ranges you've specified.

0
 
LVL 16

Expert Comment

by:carsRST
ID: 36537873
Sorry...make sure to include a "dot" before the Ranges.


Corrected code below.
'YOUR CODE
appExcel.Workbooks.Open strFolderPath & strPath
appExcel.Visible = True



Dim rng As Range
Dim sht As Worksheet

'loop through each sheet
For a = 1 To ActiveWorkbook.Sheets.Count

    With ActiveWorkbook.Sheets(a)
    
        'set range
        Set rng = .Range("B10:D10")
        
        'get value from range
        For i = 1 To rng.Columns.Count
            strValueFromRange = rng(i).Value
            
            'execute SQL INSERT
        Next
        
        
        'set NEW range selection
        Set rng = .Range("B2:D2")
        
        'get value from range
        For i = 1 To rng.Columns.Count
            strValueFromRange2 = rng(i).Value
            
            'execute SQL INSERT
        Next
        
    End With

Next a

Open in new window

0
Backup Your Microsoft Windows Server®

Backup all your Microsoft Windows Server – on-premises, in remote locations, in private and hybrid clouds. Your entire Windows Server will be backed up in one easy step with patented, block-level disk imaging. We achieve RTOs (recovery time objectives) as low as 15 seconds.

 

Author Comment

by:centralmike
ID: 36538688
I think your close. Still not working.  I will you send you a copy of the function.  The excel workbooks have multiple sheets in them.  All the workbooks have a sheet called "test" where I want to reference the data from.  Here is the entire function.  You can the way I am inserting the records into the table.

Public Function MYPREMLOAD2()


    Dim strPath As String, strFolderPath As String
    Dim appExcel As Excel.Application
    Dim MyDB As DAO.Database, MyRS As DAO.Recordset
   ' Dim rng As Range
    'Dim LastRow As Long
   
    DoCmd.SetWarnings False
    strsql = "Delete * From tblPolicyLoad;"
    DoCmd.RunSQL strsql
    DoCmd.SetWarnings True
 
    Set MyDB = CurrentDb()
   
    Set MyRS = MyDB.OpenRecordset("tblPolicyLoad", dbOpenDynaset)
     
 
    strFolderPath = "X:\Special Risk\miketesting\KARA\"
    strPath = "X:\Special Risk\miketesting\KARA\*.xls"
     
    strPath = Dir(strPath, vbNormal)
    Set appExcel = CreateObject("Excel.Application")
     

    Do While strPath <> ""
        appExcel.Workbooks.Open strFolderPath & strPath
        appExcel.Visible = True
       
      Dim rng As Range
      Dim sht As Worksheet

'loop through each sheet
For a = 1 To ActiveWorkbook.Sheets.Count

    With ActiveWorkbook.Sheets(a)
   
        'set range
        Set rng = .Range("C8:C10")
       
        'get value from range
        For i = 1 To rng.Columns.Count
            strValueFromRange = rng(i).Value
            With MyRS
            .AddNew
            !Benefit_Period = UCase(appExcel.Range("C8").Value)
            !EFFECTIVE_DATE = UCase(appExcel.Range("C9").Value)
            !FileName = UCase(appExcel.Range("C10").Value)
            .Update
            End With
            'execute SQL INSERT
        Next
 End With
 Next a

  strPath = Dir
    Loop
     
    appExcel.Quit
    Set appExcel = Nothing
    'appExcel.ActiveWorkbook.Close
    MyRS.Close
    Set MyRS = Nothing
     
    MsgBox "This Process has completed!"
End Function
0
 

Author Comment

by:centralmike
ID: 36543851
Do you have any additional suggestions.
0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 36547236
Thanks Mike for the email. I can see that carsRST is already helping you with the query :)

I would suggest that you be patient and wait for his reply :)

Sid
0
 
LVL 16

Expert Comment

by:carsRST
ID: 36553973
Mike, I'm not able to completely test, but give this a shot.  
Public Function MYPREMLOAD2()


    Dim strPath As String, strFolderPath As String
    Dim appExcel As Excel.Application
    Dim MyDB As DAO.Database, MyRS As DAO.Recordset
    
    DoCmd.SetWarnings False
    strsql = "Delete * From tblPolicyLoad;"
    DoCmd.RunSQL strsql
    DoCmd.SetWarnings True
 
    Set MyDB = CurrentDb()
    
    Set MyRS = MyDB.OpenRecordset("tblPolicyLoad", dbOpenDynaset)
     
  
    strFolderPath = "X:\Special Risk\miketesting\KARA\"
    strPath = "X:\Special Risk\miketesting\KARA\*.xls"
     
    strPath = Dir(strPath, vbNormal)
    Set appExcel = CreateObject("Excel.Application")
     

    Do While strPath <> ""
        appExcel.Workbooks.Open strFolderPath & strPath
        appExcel.Visible = True
    
        With ActiveWorkbook.Sheets("test")
                With MyRS
                    .AddNew
                    !Benefit_Period = UCase(.Range("C8").Value)
                    !EFFECTIVE_DATE = UCase(.Range("C9").Value)
                    !Filename = UCase(.Range("C10").Value)
                    .Update
                End With
                'execute SQL INSERT
        End With
        
        appExcel.ActiveWorkbook.Close
    
        strPath = Dir
    Loop
     
    appExcel.Quit
    Set appExcel = Nothing
    
    MyRS.Close
    Set MyRS = Nothing
     
    MsgBox "This Process has completed!"
End Function

Open in new window

0
 
LVL 16

Accepted Solution

by:
carsRST earned 500 total points
ID: 36553978
Sorry I had to make one additional change since it looks as if you're running outside of Excel itself.
Public Function MYPREMLOAD2()


    Dim strPath As String, strFolderPath As String
    Dim appExcel As Excel.Application
    Dim MyDB As DAO.Database, MyRS As DAO.Recordset
    
    DoCmd.SetWarnings False
    strsql = "Delete * From tblPolicyLoad;"
    DoCmd.RunSQL strsql
    DoCmd.SetWarnings True
 
    Set MyDB = CurrentDb()
    
    Set MyRS = MyDB.OpenRecordset("tblPolicyLoad", dbOpenDynaset)
     
  
    strFolderPath = "X:\Special Risk\miketesting\KARA\"
    strPath = "X:\Special Risk\miketesting\KARA\*.xls"
     
    strPath = Dir(strPath, vbNormal)
    Set appExcel = CreateObject("Excel.Application")
     

    Do While strPath <> ""
        appExcel.Workbooks.Open strFolderPath & strPath
        appExcel.Visible = True
    
        With appExcel.ActiveWorkbook.Sheets("test")
                With MyRS
                    .AddNew
                    !Benefit_Period = UCase(.Range("C8").Value)
                    !EFFECTIVE_DATE = UCase(.Range("C9").Value)
                    !Filename = UCase(.Range("C10").Value)
                    .Update
                End With
                'execute SQL INSERT
        End With
        
        appExcel.ActiveWorkbook.Close
    
        strPath = Dir
    Loop
     
    appExcel.Quit
    Set appExcel = Nothing
    
    MyRS.Close
    Set MyRS = Nothing
     
    MsgBox "This Process has completed!"
End Function

Open in new window

0
 

Author Closing Comment

by:centralmike
ID: 36573754
This code worked perfectly.
0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Title # Comments Views Activity
Moving SharePoint 3.0 role to differen server 7 42
Windows 7 Share with concurrent edits(Excel) 3 30
Hlookup formula help 14 19
Where is user Lync data stored 4 54
User Beware!  This is a rather permanent solution to removing your email from an exchange server.  The only way to truly go back is to have your exchange administrator restore your mailbox from backups.  This is usually the option of last resort.  A…
Article by: Leon
Software Metering within our group of companies has always been an afterthought until auditing of software and licensing became a pain point. Orchestrator and SCCM metering gave us the answer and it was an exciting process.
The viewer will learn how to use a discrete random variable to simulate the return on an investment over a period of years, create a Monte Carlo simulation using the discrete random variable, and create a graph to represent the possible returns over…
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.

947 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

21 Experts available now in Live!

Get 1:1 Help Now