Need help importing new data into current spreadsheet


New Member
Mar 2, 2017
Hello I know it a lot of code but im keep getting stuck on the bolded area below and I cant figure out why. I am trying to bring in new data but I keep getting an error. Can someone please assist?

Option Compare Database
Option Explicit

Function ImportAchievers()
    Dim strSQL As String
    Dim XLFile As String
    XLFile = SelectFile
    If XLFile = "" Then Exit Function
    If Not PrepXL(XLFile) Then Exit Function
    DoCmd.SetWarnings False
    'empty the AchieversImportWork table'
    strSQL = "DELETE AchieversImportWork.* FROM AchieversImportWork;"
    DoCmd.RunSQL (strSQL)
    'Append to STR fields in the AchieversImportWork table'
    strSQL = "INSERT INTO AchieversImportWork ( LoginIDStr, LastStr, FirstStr, PointsEarnedStr, AwardDateStr, AwardLevelStr, uploaddateStr ) " _
        & "SELECT AcheiversImport.[Login ID], AcheiversImport.LAST, AcheiversImport.FIRST, AcheiversImport.[POINTS EARNED], AcheiversImport.[Award Date], AcheiversImport.[AWARD LEVEL], AcheiversImport.[upload date] " _
        & "FROM AcheiversImport;"
    DoCmd.RunSQL (strSQL)
    'plug the value from the STR fields'
    strSQL = "UPDATE AchieversImportWork SET AchieversImportWork.LoginID = [LoginIDStr], AchieversImportWork.[Last] = [LastStr], AchieversImportWork.[First] = [FirstStr], AchieversImportWork.PointsEarned = [PointsEarnedStr], AchieversImportWork.AwardDate = [AwardDateStr], AchieversImportWork.AwardLevel = [AwardLevelStr], AchieversImportWork.uploaddate = [uploaddateStr];"
    DoCmd.RunSQL (strSQL)
    CreateErrorStr ("LoginID")
    CreateErrorStr ("Last")
    CreateErrorStr ("First")
    CreateErrorStr ("PointsEarned")
    CreateErrorStr ("AwardDate")
    CreateErrorStr ("AwardLevel")
    CreateErrorStr ("uploaddate")
    'show duplicates of the same date and ID'
    strSQL = "UPDATE AchieversImportWork INNER JOIN AchieversData ON (AchieversImportWork.LoginID = AchieversData.LoginID) AND (AchieversImportWork.AwardDate = AchieversData.AwardDate) SET AchieversData.Notes = 'Remove';"
    DoCmd.RunSQL (strSQL)
    'remove duplicates with the same date and ID so employer is not paid twice'
    strSQL = "DELETE AchieversData.*, AchieversData.Notes FROM AchieversData WHERE (((AchieversData.Notes)='Remove'));"
    DoCmd.RunSQL (strSQL)
    'Employee might have received awards in prior years'
    strSQL = "UPDATE AchieversImportWork INNER JOIN AchieversData ON AchieversImportWork.LoginID = AchieversData.LoginID SET AchieversData.Notes = 'Duplicate Possibly Twice';"
    DoCmd.RunSQL (strSQL)
     'append from achieverimportwork to achieversData'
    strSQL = "INSERT INTO AchieversData ( LoginID, [Last], [First], PointsEarned, AwardDate, AwardLevel, uploaddate, ErrStr ) " _
        & "SELECT AchieversImportWork.LoginID, AchieversImportWork.Last, AchieversImportWork.First, AchieversImportWork.PointsEarned, AchieversImportWork.AwardDate, AchieversImportWork.AwardLevel, AchieversImportWork.uploaddate, AchieversImportWork.ErrStr FROM AchieversImportWork " _
        & "WHERE (((AchieversImportWork.ErrStr) Is Null));"
   DoCmd.RunSQL (strSQL)
   DoCmd.SetWarnings True
End Function

Sub CreateErrorStr(Fldname As String)

    Dim rst As Recordset
    Dim strSQL As String
    Dim strFld As String
    Dim ErrStr As String

    strFld = Fldname & "str"
    strSQL = "SELECT AchieversImportWork.* FROM AchieversImportWork WHERE (((AchieversImportWork." & Fldname & ") Is Null));"
    Set rst = Application.CurrentDb.OpenRecordset(strSQL)
    If rst.RecordCount = 0 Then
    Exit Sub
        End If
    ErrStr = "ERROR " & rst!LoginIDStr & " " & Fldname & " value is " & rst(strFld)
    rst!ErrStr = ErrStr
    If rst.EOF Then Exit Do
End Sub

Function SelectFile()
    'Dim fd As Office.FileDialog
    'Set fd = Application.FileDialog(msoFileDialogFilePicker)
        Dim fd As Object
        Set fd = Application.FileDialog(1)
    With fd
        .InitialFileName = "" & CurrentProject.Path & ".xls"
    .Title = "Sleect a File"
    .Filters.Add "Excel Files", "*.xlsx"
    If .Show Then
        SelectFile = .SelectedItems(1)
        SelectFile = ""
    End If
    End With
    Set fd = Nothing
End Function

Function PrepXL(XLFile As String)
Dim impfile As String
Dim xlapp As Excel.Application
Dim xlbk As Excel.Workbook
Dim xlsht As Excel.Workbook
'dim xlapp as object
'dim xlbk as object
'dim xlsht as object
Dim chkXL As String

[B]'impfile = CurrentProject.Path & ".xlsx"[/B]
[B]impfile = CurrentProject.Path & ".xlsx"[/B]
[B]If Dir(impfile) <> "" Then[/B]
[B]    Kill (impfile)[/B]
[B]End If[/B]
[B]FileCopy XLFile, impfile[/B]
[B]Set xlapp = CreateObject("excel.Application")[/B]
[B]Set xlbk = xlapp.Workbooks.Open(impfile)[/B]
[B]Set xlsht = xlbk.Sheet(1)[/B]
[B]chkXL = xlsht.Range("A1").Value[/B]
[B]If Mid(chkXL, 1, 16) <> "Login ID" Then[/B]
[B]Set xlbk = Nothing[/B]
[B]Set xlapp = Nothing[/B]
[B]MsgBox (" This is not the correct file!")[/B]
[B]PrepXL = False[/B]
[B]Exit Function[/B]
[B]End If[/B]

 With xlapp
    .ActiveCell.Offset(0, 3).Range("A1").Select
    .ActiveCell.FormulaR1C1 = "POINTS EARNED"
    .ActiveCell.Offset(1, 0).Range("A1").Select
    .Sheets("Sent to Dianna").Select
    .Sheets("Sent to Dianna").Name = "April 2018"
    .Sheets("Achievers Upload").Select
    End With
   Set xlbk = Nothing
   Set xlapp = Nothing
   deletbl ("AcheiversImport")
   DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "AcheiversImport", impfile, True
   PrepXL = True
End Function

Sub deletbl(tblname As String)
    On Error Resume Next
    Application.CurrentDb.TableDefs.Delete tblname
End Sub
Last edited by a moderator:

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.

Leith Ross

Well-known Member
Mar 17, 2008
Office Version
  1. 2010
  2. 2007
  1. Windows
Hello jojo52479,

When you encounter errors you should provide the error number, error description, and the line where the error occurs.

Watch MrExcel Video

Forum statistics

Latest member
aaryan bl

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back