Need help importing new data into current spreadsheet

[jojo52479]

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
    rst.Close
    Exit Sub
        End If
    Do
    ErrStr = "ERROR " & rst!LoginIDStr & " " & Fldname & " value is " & rst(strFld)
    rst.Edit
    rst!ErrStr = ErrStr
    rst.Update
    rst.MoveNext
    If rst.EOF Then Exit Do
Loop
rst.Close
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.Clear
    .Filters.Add "Excel Files", "*.xlsx"
    If .Show Then
        SelectFile = .SelectedItems(1)
    Else
        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]xlsht.Activate[/B]
[B]chkXL = xlsht.Range("A1").Value[/B]
[B]If Mid(chkXL, 1, 16) <> "Login ID" Then[/B]
[B]xlbk.Close[/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("Points").Select
    .ActiveWindow.SelectedSheets.Delete
    .Sheets("Achievers Upload").Select
    .ActiveWindow.SelectedSheets.Delete
    End With
    
   xlbk.Save
   xlbk.Close
   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

 

[Leith Ross]

Hello jojo52479,

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