• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 274
  • Last Modified:

MICROSOFT ACCESS 2007/Excel 2007

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
centralmike
Asked:
centralmike
  • 6
  • 4
1 Solution
 
carsRSTCommented:
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
 
centralmikeAuthor Commented:
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
 
carsRSTCommented:
>>  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
What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

 
carsRSTCommented:
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
 
carsRSTCommented:
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
 
centralmikeAuthor Commented:
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
 
centralmikeAuthor Commented:
Do you have any additional suggestions.
0
 
SiddharthRoutCommented:
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
 
carsRSTCommented:
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
 
carsRSTCommented:
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
 
centralmikeAuthor Commented:
This code worked perfectly.
0

Featured Post

Keep up with what's happening at Experts Exchange!

Sign up to receive Decoded, a new monthly digest with product updates, feature release info, continuing education opportunities, and more.

  • 6
  • 4
Tackle projects and never again get stuck behind a technical roadblock.
Join Now