Need help importing new data into current spreadsheet

jojo52479

New Member
Joined
Mar 2, 2017
Messages
24
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?


Code:
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
 
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
Joined
Mar 17, 2008
Messages
1,874
Office Version
  1. 2010
  2. 2007
Platform
  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

Threads
1,130,371
Messages
5,641,753
Members
417,234
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 MrExcel.com.
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 "mrexcel.com".
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
Top