Import data from Excel to Access based on criteria (1 Viewer)

[mari_hitz]

Hi!
Hope you are good and having a good 2017. I would like to obtain your help on the following: I have a table with information that everyday gets updated. I have an access database that has the same table. I have a vba code that brings the data from that excel file and it works just fine. However, I would like to only bring the new rows on the file that have been added today or the day before. The table has a field named "Date Logged" in which the dates are entered. Is there any way I can modify the code that I have so I can import only the information from the day before or from the same day? Thanks!

Option Compare Database

Public Function MyFileExists(pstrFile As String) As Boolean
Dim strTemp As String
On Error Resume Next
strTemp = Dir$(pstrFile)

If strTemp <> "" Then
MyFileExists = True
End If
End Function

Public Function OpenExcelAddWorkbook(strFullFileName As String, _
strWorkbookName As String, _
strQueryName As String, _
Optional blnClose As Boolean) As Boolean
'Format and open Excel spreadsheet
'Creates an Excel database
'Created by Scott Walker, Accessible Data Solutions 02/8/2011
On Error GoTo Err_Proc

If Len(strFullFileName) = 0 Then
MsgBox "Missing filename.", vbCritical + vbOKOnly, "Error"
Exit Function
End If

If Len(strWorkbookName) = 0 Then
MsgBox "Missing sheet name.", vbCritical + vbOKOnly, "Error"
Exit Function
End If

If Len(strQueryName) = 0 Then
MsgBox "Missing query name or SQL string.", vbCritical + vbOKOnly, "Error"
Exit Function
End If

Dim objApp As Object
Dim intSR As Integer
Dim dbs As DAO.Database
Dim rsRecords As DAO.Recordset
Dim strMsg As String
Dim lngMaxCol As Long
Dim lngMaxRow As Long
Dim i As Long
Dim strHeading As String
Dim blnWorksheetExists As Boolean
Dim blnSpreadsheetExists As Boolean

' Open database
Set dbs = CurrentDb

' Open recordset
Set rsRecords = dbs.OpenRecordset(strQueryName)

If rsRecords.EOF And rsRecords.BOF Then
MsgBox "Query or SQL returned no records.", vbCritical + vbOKOnly, "Error"
Exit Function
End If

' Open excel and add workbook
Set objApp = CreateObject("Excel.Application")
objApp.UserControl = True

' If no physical location passed, Excel will use the users working directory
' i.e. My Documents. Therefore the test for the existance of the spreadsheet
' will fail to locate it.
blnSpreadsheetExists = MyFileExists(strFullFileName)

If blnSpreadsheetExists Then
objApp.Workbooks.Open strFullFileName
Else
objApp.Workbooks.Add
End If

' Prompts are enabled to prevent overwriting of existing spreadsheet
objApp.DisplayAlerts = True
objApp.ActiveWorkbook.Worksheets(strWorkbookName).Activate

' Test if Worksheets exists
If blnWorksheetExists = True Then
MsgBox "Workbook " & strWorkbookName & " exists!" & _
vbCrLf & vbCrLf & "Data not changed.", vbInformation + vbOKOnly, "Error"
Exit Function
Else
objApp.ActiveWorkbook.Worksheets.Add.Name = "" & strWorkbookName & ""
End If

With objApp.Worksheets("" & strWorkbookName & "")
lngMaxCol = rsRecords.Fields.Count

If rsRecords.RecordCount > 0 Then
rsRecords.MoveLast
rsRecords.MoveFirst
lngMaxRow = rsRecords.RecordCount

If lngMaxRow > 65536 Then
strMsg = Format(lngMaxRow, "#,##0") & " exceeds the maximum " & _
"of 65,536 rows that can be " & vbCrLf

If blnSpreadsheetExists Then
strMsg = strMsg & "exported directly...you will have " & _
"to manully export the " & vbCrLf & _
strMsg = strMsg & "into a spreadsheet."
MsgBox strMsg

rsRecords.Close
Set rsRecords = Nothing
Set dbs = Nothing

objApp.DisplayAlerts = False
objApp.Quit
DoCmd.OpenQuery strQueryName, acViewNormal, acReadOnly

MsgBox "Now use the File + Export manual method."
Exit Function

Else

strMsg = strMsg & "exported directly...switching to transfer."
MsgBox strMsg

rsRecords.Close
Set rsRecords = Nothing
Set dbs = Nothing

objApp.DisplayAlerts = False
objApp.Quit

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, strQueryName, strFullFileName, True

RunExcel strFullFileName
Exit Function

End If

End If

' Let user see the data added

objApp.Visible = True
For i = 1 To lngMaxCol
.Cells(1, i).FormulaR1C1 = rsRecords.Fields(i - 1).Name
.Cells(1, i).Font.Bold = True

' ColorIndex values: 0 Auto, 1 Black, 2 White, 3 Red, 5 Blue,
'6 Yellow, 10 Green, 40 Tan, 36 Light Yellow, 35 Light Green,
'34 Light Turquoise, 37 Pale Blue
.Cells(1, i).Font.ColorIndex = 1
.Cells(1, i).Interior.ColorIndex = 35
.Cells(1, i).Interior.Pattern = 1 'Excel ref variable xlSolid = 1
.Cells(1, i).Interior.PatternColorIndex = -4105 'Excel ref variable PatternColorIndex = -4105

Next

.Range(.Cells(2, 1), .Cells(lngMaxRow, lngMaxCol)).CopyFromRecordset rsRecords
'Excel ref variable xlLeft = -4131
.Range(.Cells(1, 1), .Cells(lngMaxRow + 1, lngMaxCol)).HorizontalAlignment = -4131
.Range(.Cells(1, 1), .Cells(lngMaxRow + 1, lngMaxCol)).AutoFilter
.Range(.Cells(1, 1), .Cells(lngMaxRow + 1, lngMaxCol)).EntireColumn.AutoFit

End If

' Select all data
.Range(.Cells(1, 1), .Cells(lngMaxRow + 1, lngMaxCol)).Select

End With

rsRecords.Close
Set rsRecords = Nothing

' Save excel spreadsheet
If blnSpreadsheetExists Then
objApp.ActiveWorkbook.Save
Else
objApp.ActiveWorkbook.SaveAs strFullFileName
End If

' Reset alerts prompts
objApp.DisplayAlerts = True
Set dbs = Nothing
If blnClose Then
objApp.Quit
End If

OpenExcelAddWorkbook = True

Exit_Proc:
Exit Function

Err_Proc:

If Err.Number = 9 Then
blnWorksheetExists = False
Resume Next
Else
MsgBox Err.Number & "-" & Err.Description
Resume Exit_Proc
End If

End Function

Function cmdImportQueryLASCHA164()
Dim filepath As String
Dim fD As Object

MsgBox "Please look for the latest Payment Election List sent by Xerox ", , "Import Payment Election List"
Set fD = Application.FileDialog(1)
With fD
    .Title = "Select File"
     .InitialFilename = CurrentProject.Path
     
     If .Show Then
        Debug.Print .selecteditems(1)
        filepath = .selecteditems(1)
     End If
End With

DoCmd.TransferSpreadsheet acImport, , "tblPymElectionCurrent", filepath, True
   
End Function

Function cmdCopyPYInactiveAetnaValBeforeDeletes()
Dim Iname As String

Iname = "PYInactAetnaValBeforeDeletes"

DoCmd.CopyObject , Iname, acTable, "CYInactAetnaValBeforeDeletes"

End Function

 

[plog]

Can you make the spreadsheet a linked table? That way you can create a query and achieve what you want.

 

[The_Doc_Man]

At least in theory you can make a spreadsheet act as a linked table with a couple of restrictions.

First, the linked table will almost certainly be read-only.

Second, you can do your import with a query but you need to use a "smart" WHERE clause to ignore records that are part of headers or are blank. This is a case where you might wish to use a layered query to divide and conquer the problem into parts you can handle. Make a SELECT query that only shows "live" data rows and ignores anything else. Then do your INSERT INTO using that query and a WHERE clause that is sensitive to the date in question. (You could make the cut-off date a parameter for a parameter query, for example.)