ExcelImport.vba

Option Compare Database



Sub ImportFromExcel(filename As String)
    ' remove any previous data
    CurrentDb.Execute "DELETE * from tbl_excelImport"
    CurrentDb.Execute "DELETE * from tbl_requests"  ' delete all previously recorded requests
    CurrentDb.Execute "DELETE * from tbl_clients"  ' delete all previously recorded clients
    
    ' import data from "Data for 2013-Sept 2015" worksheet
    DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, "tbl_excelImport", filename, True, "Data for 2013-Sept 2015!E1:AK2500"
    
    ' transfer from tbl_excelImport to tbl_requests and tbl_clients
    ExtractFromImportedData
End Sub


Sub ExtractFromImportedData()
    ' open neccesary recordsets
    Dim import As DAO.Recordset
    Set import = CurrentDb.OpenRecordset("tbl_excelImport")
    
    Dim req As DAO.Recordset
    Set req = CurrentDb.OpenRecordset("tbl_requests")
    
    Dim cli As DAO.Recordset
    Set cli = CurrentDb.OpenRecordset("tbl_clients")
    
    Set clientNames = CreateObject("Scripting.Dictionary")
    
    ' loop through records in tbl_excelImport
    Do Until import.EOF = True
        ' check that there is data in the record
        If Not IsNull(import!ClientName) And Not import!ClientName = "" Then
            ' check if a customer with this name already exists
            If Not (clientNames.Exists(import!ClientName)) Then
                ' add a new client and grab from import fields
                cli.AddNew
                cli!ClientName = import!ClientName
                cli!Address = import!Address
                cli!PostCode = import!PostCode
                cli!ReferringAgency = import![Referring Agency]
                ' cli!ReferringAgencyNumber does not exist in excel spreadsheet
                cli!ReferringStaffName = import![Referrer Name]
                ' cli!ClientComments does not exist in excel spreadsheet
                cli![Adults16-21] = ToNumber(import![16-21])
                cli![Adults21-40] = ToNumber(import![22-40])
                cli![Adults41-60] = ToNumber(import![41-60])
                cli![Adults60Plus] = ToNumber(import![60+])
                cli![Children0-4] = ToNumber(import![0-4])
                cli![Children5-11] = ToNumber(import![5-11])
                cli![Children12-15] = ToNumber(import![12-16])
                cli![Children16-18] = ToNumber(import![16-18])
                cli.Update
                
                clientNames.Add import!ClientName, clientNames.Count  ' use an arbritary unique key as this is unimportant
            Else
            ' this is NOT a new customer, so don't add new details
                'MsgBox import!ClientName
                Dim i As Integer
                i = 0
            End If
        
        End If
        
        import.MoveNext
    Loop
    
    ' clean up recordsets
    import.Close
    Set import = Nothing
    req.Close
    Set req = Nothing
    cli.Close
    Set cli = Nothing
    
    Set clientNames = Nothing
        
End Sub

Function ToBool(variantData As Variant) As Boolean
    
    Dim stringData
    stringData = CStr(variantData)
    
    If (stringData = "1") Then
        ToBool = True
    Else
        ToBool = False
    End If

End Function

Function ToNumber(variantData As Variant) As Integer

    If (IsNull(variantData)) Then
        ToNumber = 0
    Else
        ToNumber = CInt(CStr(variantData))
    End If

End Function

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
  IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function