centralmike
asked on
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("tblPol icyLoad", dbOpenDynaset)
strFolderPath = "X:\Special Risk\miketesting\KARA\"
strPath = "X:\Special Risk\miketesting\KARA\*.xl s"
strPath = Dir(strPath, vbNormal)
Set appExcel = CreateObject("Excel.Applic ation")
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.C lose
MyRS.Close
Set MyRS = Nothing
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("tblPol
strFolderPath = "X:\Special Risk\miketesting\KARA\"
strPath = "X:\Special Risk\miketesting\KARA\*.xl
strPath = Dir(strPath, vbNormal)
Set appExcel = CreateObject("Excel.Applic
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.C
MyRS.Close
Set MyRS = Nothing
ASKER
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
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
>> 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.
Assuming you know the name of the sheet, did you change it in this line of code?
Set rng = Activeworkbook.sheets("...
>>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
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.
Sorry...make sure to include a "dot" before the Ranges.
Corrected code below.
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
ASKER
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("tblPol icyLoad", dbOpenDynaset)
strFolderPath = "X:\Special Risk\miketesting\KARA\"
strPath = "X:\Special Risk\miketesting\KARA\*.xl s"
strPath = Dir(strPath, vbNormal)
Set appExcel = CreateObject("Excel.Applic ation")
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.Coun t
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.C lose
MyRS.Close
Set MyRS = Nothing
MsgBox "This Process has completed!"
End Function
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("tblPol
strFolderPath = "X:\Special Risk\miketesting\KARA\"
strPath = "X:\Special Risk\miketesting\KARA\*.xl
strPath = Dir(strPath, vbNormal)
Set appExcel = CreateObject("Excel.Applic
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.Coun
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")
!EFFECTIVE_DATE = UCase(appExcel.Range("C9")
!FileName = UCase(appExcel.Range("C10"
.Update
End With
'execute SQL INSERT
Next
End With
Next a
strPath = Dir
Loop
appExcel.Quit
Set appExcel = Nothing
'appExcel.ActiveWorkbook.C
MyRS.Close
Set MyRS = Nothing
MsgBox "This Process has completed!"
End Function
ASKER
Do you have any additional suggestions.
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
I would suggest that you be patient and wait for his reply :)
Sid
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
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
This code worked perfectly.
Dim rng As Range
Set rng = Activeworkbook.sheets("...
'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