Import Specific Cells from Multiple Excel Workbooks to Access Database (1 Viewer)

' open file API call [URL]http://access.mvps.org/access/api/api0001.htm[/URL]

'1.Create a new form.
'2.Add a list box, and set these properties:
    'Name              lstFileList
   ' Row Source Type   Value List
'3.Set the On Load property of the form to:
    '[Event Procedure]
'4.Click the Build button (...) beside this. Access opens the code window. Set up the event procedure like this:
    'Private Sub Form_Load()
        'Call ListFiles("C:\Data", , , Me.lstFileList)
    'End Sub
' To list the files in C:\Data, open the Immediate Window (Ctrl+G), and enter:
    'Call ListFiles("C:\Data")
'To limit the results to Excel files:
    'Call ListFiles("C:\MyFolder\MySubFolder\", "*.xls*")
 

   
'--------------------------------------------------------------------------------
Public Sub FillTableWithFiles()
      Dim MyFoldername As String
10    On Error GoTo ErrorTrap
20    MyFoldername = InputBox("Please enter the Path for the top level folder", "Starting Folder", "C:\Myfolder\MySubfolder\")
      ' starting path for harvest
30    Call ListFiles(MyFoldername, "*.xls*", True)
40    Exit Sub
ErrorTrap:
50     MsgBox "An error occured: " & Err.Description, vbCritical, "Error Message during process - Please take note"
End Sub

Public Function ListFiles(strPath As String, Optional strFileSpec As String, _
    Optional bIncludeSubfolders As Boolean, Optional lst As ListBox)
10    On Error GoTo Err_Handler
          'Purpose:   List the files in the path.
          'Arguments: strPath = the path to search.
          '           strFileSpec = "*.*" unless you specify differently.
          '           bIncludeSubfolders: If True, returns results from subdirectories of strPath as well.
          '           lst: if you pass in a list box, items are added to it. If not, files are listed to immediate window.
          '               The list box must have its Row Source Type property set to Value List.
          'Method:    FilDir() adds items to a collection, calling itself recursively for subfolders.
          Dim colDirList As New Collection
          Dim varItem As Variant
          
20        Call FillDir(colDirList, strPath, strFileSpec, bIncludeSubfolders)
          
          'Add the files to a list box if one was passed in. Otherwise list to the Immediate Window.
30        If lst Is Nothing Then
40            For Each varItem In colDirList
50                Debug.Print varItem
60                ProcessExcelFile strPath, CStr(varItem)
70                DoEvents
80            Next
90        Else
100           For Each varItem In colDirList
110           lst.AddItem varItem
120           DoEvents
130           Next
140       End If
Exit_Handler:
150       Exit Function
Err_Handler:
160       MsgBox "Error " & Err.Number & ": " & Err.Description
170       Resume Exit_Handler
End Function
Private Function FillDir(colDirList As Collection, ByVal strFolder As String, strFileSpec As String, _
    bIncludeSubfolders As Boolean)
          'Build up a list of files, and then add add to this list, any additional folders
          Dim strTemp As String
          Dim colFolders As New Collection
          Dim vFolderName As Variant
          'Add the files to the folder.
10        strFolder = TrailingSlash(strFolder)
20        strTemp = Dir(strFolder & strFileSpec)
30        Do While strTemp <> vbNullString
40            colDirList.Add strFolder & strTemp
50            strTemp = Dir
60        Loop
70        If bIncludeSubfolders Then
              'Build collection of additional subfolders.
80            strTemp = Dir(strFolder, vbDirectory)
90            Do While strTemp <> vbNullString
100               If (strTemp <> ".") And (strTemp <> "..") Then
110                   If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then
120                       colFolders.Add strTemp
130                   End If
140               End If
150               strTemp = Dir
160           Loop
              'Call function recursively for each subfolder.
170           For Each vFolderName In colFolders
180               Call FillDir(colDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True)
190           Next vFolderName
200       End If
End Function
Public Function TrailingSlash(varIn As Variant) As String
10        If Len(varIn) > 0& Then
20            If Right(varIn, 1&) = "\" Then
30                TrailingSlash = varIn
40            Else
50                TrailingSlash = varIn & "\"
60            End If
70        End If
End Function

Option Explicit
Option Compare Database
' //////////////   Used in Form ////////////////
' Suggestion - open the Immediate Window to see Debug.Print statements output
Public Sub ProcessExcelFile(sFile As String, sFileName As String)
      'sFile is the full path of the file, sFileName is just the filename
      Dim Objxl As Excel.Application
      Dim objWkb As Excel.Workbook
      Dim objSht As Excel.Worksheet
      Dim sA3Val As String
      Dim fieldArray() As String
      Dim SQLString As String
      Dim WorkSheetLastRow As Long
      Dim LastRowonColumn2 As Long
      Dim LastRowAutocount As Long
      Dim XLWellName As String ' cell A2
      Dim XLFormType As String ' cell A4
      Dim XLSheet1Year As String    ' cell A14 on flare
      Dim XLWorksheetCount As Integer
      Dim isFlare As Boolean
10    isFlare = False
20    On Error Resume Next
30    If Err.Number = 0 Then  'Excel was not open
40        Err.Clear
50        Set Objxl = New Excel.Application
60    End If
70    Objxl.Visible = False
80    Set objWkb = Objxl.Workbooks.Open(sFileName)
90        objWkb.Sheets(1).Activate
100       XLWorksheetCount = objWkb.Sheets.Count
110       LastRowonColumn2 = objWkb.ActiveSheet.Cells(objWkb.ActiveSheet.Rows.Count, 2).End(xlUp).Row
          'WorkSheetLastRow = LastRowonColumn2()  Flair is Max 44 where Emission is max 38
          ' Title is in B4 for both types
120       DoEvents
          
130               If LastRowonColumn2 > 46 Then  ' This  excel template never goes past 46
                      ' skip - junk excel sheets Check to see if the word "Monthy" is there befor starting
140               Else
                          ' Basic sheet information
150                       XLWellName = objWkb.ActiveSheet.Range("B2")
160                       XLFormType = objWkb.ActiveSheet.Range("B4")
170                           If Left(XLFormType, 7) <> "Monthly" Then
180                                           Objxl.Quit
190                                           Set objSht = Nothing
200                                           Set objWkb = Nothing
210                                           Set Objxl = Nothing
220                                       Exit Sub
                                          ' all the other non-report XL were missing this
230                           End If
                          
240                       If objWkb.ActiveSheet.Range("B12") = "Year" Then ' is this the template where B12 has the word "Year"  ??
250                           XLSheet1Year = objWkb.ActiveSheet.Range("B14")  ' does the word Year appear here?
260                           isFlare = True  ' decision on what table gets what data harvested
270                       Else
280                           XLSheet1Year = objWkb.ActiveSheet.Range("B10")
                              ' Emissions
290                       End If
                      
300                       DoEvents
310                       LastRowAutocount = InsertIntoTableReturnAutoCount("ExcelInventory", Trim(sFile), sFileName, LastRowonColumn2, XLWellName, XLFormType, XLSheet1Year, XLWorksheetCount)
                          ' Flare or Tank - some templates are Flare, the rest Tank - take data to proper table - Return Autocount number
320                       If isFlare Then
330                           FlareTable Objxl, LastRowAutocount
340                       Else
                              
350                       End If
360               End If
370               Objxl.Quit
380               Set objSht = Nothing
390               Set objWkb = Nothing
400               Set Objxl = Nothing
410               SQLString = ""
420   Exit Sub
End Sub
Public Sub FlareTable(Objxl As Excel.Application, ID_workbook As Long)      ' Flare
      Dim rst As DAO.Recordset, lngANumber As Long
      Dim WorkSheetCount As Integer
      Dim X As Integer
      Dim Y As Integer
      Dim Row As Integer
      Dim CalMonth As String
      Dim Throughput As Integer
      Dim NOx As Integer
      Dim CO As Integer
      Dim VOC As Integer
      Dim CalYear As Integer
      Dim BTURating As Integer
      Dim MolWeight As Double
      Dim VOCWeight As Double
10        WorkSheetCount = Objxl.Sheets.Count
          
20        For X = WorkSheetCount To 1 Step -1
30                Objxl.Sheets(X).Activate
40                Set rst = CurrentDb.OpenRecordset("Flare", dbOpenDynaset) ' defaults to dBopen table since it is local table
                  'InsertIntoTableReturnAutoCount = -99 ' use as error trap return value
50                Debug.Print "Add record for excel file name Flare " & ID_workbook - Foreign; Key
                          ' Read Flare Excel Worksheet
60                            Objxl.Range("A1").Select ' Starting point
                                'Debug.Print ActiveCell.Value & "  Start location "
70                            CalYear = Objxl.ActiveCell.Offset(13, 1).Range("A1").Value
80                            BTURating = Objxl.ActiveCell.Offset(13, 5).Range("A1").Value
90                            MolWeight = Objxl.ActiveCell.Offset(13, 7).Range("A1").Value
100                           VOCWeight = Objxl.ActiveCell.Offset(13, 9).Range("A1").Value
110                           For Row = 17 To 39 Step 2
120                                 CalMonth = Objxl.ActiveCell.Offset(Row, 1).Range("A1").Value
130                                 Throughput = Objxl.ActiveCell.Offset(Row, 3).Range("A1").Value
140                                 NOx = Objxl.ActiveCell.Offset(Row, 5).Range("A1").Value
150                                 CO = Objxl.ActiveCell.Offset(Row, 7).Range("A1").Value
160                                 VOC = Objxl.ActiveCell.Offset(Row, 9).Range("A1").Value
                                    ' if 2nd one is not null then
                                    'If Throughput < 1 Then Exit Sub   ' this doesn't work if records started mid year (e.g. Jan is blank)
                                    'Debug.Print CalYear; CalMonth; vbTab; Throughput; vbTab; NOx; vbTab; CO; vbTab; VOC; vbTab; Row
                                    ' Write above to a recordset
                              
                              ' Read one - then add new row
170                                   rst.AddNew
180                                       rst!ID_workbook = ID_workbook
190                                       rst!Workbooksheet = X
200                                       rst![CalYear] = CalYear ' NEED TO GET THIS
210                                       rst![CalMonth] = CalMonth          ' Jan, Feb, Mar
220                                       rst![Throughput] = Throughput
                                          'rst![Yearfield] = CalYear 'Yearfield          ' cell B4
230                                       rst![NOx] = NOx
240                                       rst![CO] = CO
250                                       rst![VOC] = VOC
260                                       rst![BTURating] = BTURating
270                                       rst![MolWeight] = MolWeight
280                                       rst![VOCWeight] = VOCWeight
                  
290                                   rst.Update
300                           Next Row
310        Next X
           
320               Debug.Print lngANumber & "   " & Err.Number
330               rst.Close
340               Set rst = Nothing
          
350   Exit Sub
ErrorTrap:
360   Debug.Print Err.Number & " " & Err.Description
End Sub
Sub HarvestFlare(Objxl As Excel.Application)
      Dim Row As Integer
      Dim CalMonth As String
      Dim Throughput As Integer
      Dim NOx As Integer
      Dim CO As Integer
      Dim VOC As Integer
10        Range("A1").Select ' Starting point
20        Debug.Print ActiveCell.Value & "  Start location "
30      For Row = 17 To 39 Step 2
40            CalMonth = ActiveCell.Offset(Row, 1).Range("A1").Value
50            Throughput = ActiveCell.Offset(Row, 3).Range("A1").Value
60            NOx = ActiveCell.Offset(Row, 5).Range("A1").Value
70            CO = ActiveCell.Offset(Row, 7).Range("A1").Value
80            VOC = ActiveCell.Offset(Row, 9).Range("A1").Value
              ' if 2nd one is not null then
90            If Throughput < 1 Then Exit Sub
100           Debug.Print CalMonth; vbTab; Throughput; vbTab; NOx; vbTab; CO; vbTab; VOC; vbTab; Row
              ' Write above to a recordset
110     Next Row
120   Exit Sub
End Sub
Public Function InsertIntoTableReturnAutoCount(LocalTableName As String, _
                                                OpenFilePath As String, _
                                                ExcelFileName As String, _
                                                LastRow As Long, _
                                                WellName As String, _
                                                FormType As String, _
                                                Yearfield As String, _
                                                WorksheetTotalCount As Integer) _
                                                As Long
      ' Builds Master Table - returns autocounter number for two tables (Tank and Flare)
      Dim rst As DAO.Recordset, lngANumber As Long
10    Set rst = CurrentDb.OpenRecordset("ExcelInventory") ' defaults to dBopen table since it is local table
20    InsertIntoTableReturnAutoCount = -99 ' use as error trap return value
30    Debug.Print "Add record for excel file name " & ExcelFileName
40    rst.AddNew
50        rst!FilePath = OpenFilePath
60        rst!ExcelFileName = ExcelFileName
70        rst![Worksheet Count] = WorksheetTotalCount ' CInt(objXL.Sheets.Count)
80        rst![WellName] = WellName           ' cell B2
90        rst![FormType] = FormType           ' cell B4
100       rst![Yearfield] = Yearfield          ' cell B4
110       rst![MaxRowNumber] = LastRow          ' Sheet 1 max row number should pre filter bigger than 44 rows
120   rst.Update
130   rst.Bookmark = rst.LastModified
140   lngANumber = rst!ID_workbook                ' return autocounter number
150   Debug.Print lngANumber & "   " & Err.Number
160   rst.Close
170   Set rst = Nothing
180   InsertIntoTableReturnAutoCount = lngANumber
190   Exit Function
End Function

Option Compare Database
Option Explicit
' in code window menu Tools - Reference - must have Excel checked
Sub BasicImportExcel2Access()
      Dim xlsht As Excel.Worksheet
      Dim xlWrkBk As Excel.Workbook
      Dim myRec As DAO.Recordset
      Dim xlApp As Excel.Application
      Dim xlWrksht As Excel.Worksheet
      Dim i As Long
10    Set myRec = CurrentDb.OpenRecordset("XLImportTest")
20    Set xlApp = CreateObject("Excel.Application")
30    Set xlWrkBk = xlApp.Workbooks.Open("C:\ImportDemo.xlsx") ' Path can be a variable from a list in a table
40    Set xlWrksht = xlWrkBk.Sheets(1) ' 1 can be a variable to loop 1..10 for example
 
50     For i = 2 To 10
 
60        myRec.AddNew
70        On Error Resume Next
80        myRec.Fields(0) = xlWrksht.Cells(i, "A") ' CInt(xlWrksht.Cells(i, "A"))  if conversion necessary
90        myRec.Fields(1) = xlWrksht.Cells(i, "B") ' cells 2 to 10 in comumn B
100       myRec.Fields(2) = xlWrksht.Cells(i, "C")
110       myRec.Update
120    Next
Set myRec = Nothing
Set xlApp = Nothing
130   Exit Sub
          ' add some real smeging error trapping to avoid big problems
End Sub