troubleshooting Question

Formatting Excel columns before importing to Access using VBA

Avatar of fatalblitz
fatalblitz asked on
Microsoft AccessVisual Basic ClassicMicrosoft ExcelMicrosoft Development
5 Comments1 Solution995 ViewsLast Modified:
I currently have VBA code that imports multiple .xls files located in a single folder into my Microsoft Access database. Before doing so, there is a portion of code that prepares the excel files (changes column names to match field names within database, searches for date columns equaling '00/00/000' and "None" values and changes them to blank " ". This is further noted in the code's comments down below. However, the code doesn't seem to work 100% and we still have to manually go back into the .xls files and do a find and replace for these Date columns that have "00/00/0000" and "None" values and replace with " ". Any suggestions as to how to update this code to remove this manual step? (highlighted in bold) Thanks




'This will prepare the excel files before importing to the database
'It will change the column names to match the field names within the database
'It will also search through the Dates columns for values such as '00/00/0000', "None" so
'that the files will import correctly
Public Function UpdateAndImport(filePath As String, file As String, workItem As Integer)
 '   Late Binding (Needs no reference set)
    Dim oXL As Object
    Dim oExcel As Object
    Dim sFullPath As String
    Dim sPath As String
    Dim TableToImport As String    'Table name within Access Database
    Dim xWs As String   'This will hold the name for the excel worksheet
    Dim xWs2 As String  'This will hold the name for the excel worksheet
    Dim upDatei As Long 'This is used in the system status progress bar
    Dim SysProg As String 'This is used in the system status bar as the message
    upDatei = 0
   
    '===============================
    'Variables used within: FIX WORKBOOK CONTENTS
        Dim count As Integer
        Dim SColumn As Integer
        Dim Scolumn2 As String
        Dim LastRow As Integer
        Dim ColumnName As String
        Dim x As Integer
        Dim i As Integer
    '================================
   
    xWs = "Format"    'Worksheet name for import
    xWs2 = "Sheet1"   'The Data Entry Dates have the worksheet name as Sheet1
   
    ' Create a new Excel instance
    Set oXL = CreateObject("Excel.Application")
     
     
    ' Only XL 97 supports UserControl Property
    On Error Resume Next
    oXL.UserControl = True
    On Error GoTo 0
     
    ' Full path of excel file to open
    sFullPath = filePath & file
    'When Visible is true it will show the excel program.  Uncomment this for testing
    'oXL.Visible = True
   
     On Error GoTo ErrHandle
    'This will open the file
    oXL.workbooks.Open (sFullPath)
    Dim objworkbook As Object
    Set objworkbook = oXL.Application.ActiveWorkbook
       
    'Update Status in text
    [Forms]![Form: Skill Area Selection]![MsgTxt] = "Editing File: " & file
    SysProg = SysCmd(acSysCmdInitMeter, "Editing File: " & file, upDatei)
    'Change workbook column headings depending on which worksheet it is
    'This will set the names of the database table
    If workItem = 1 Then
        TableToImport = "Qualifications Overview"
        DoCmd.OpenForm "FieldInfo", acDesign, , , acFormPropertySettings, acHidden
        'The following lines will change the worksheet field headers (The individual column names)
        objworkbook.worksheets(xWs).range("A1") = [Forms]![FieldInfo]![Text0].DefaultValue
        objworkbook.worksheets(xWs).range("B1") = [Forms]![FieldInfo]![Text6].DefaultValue
        objworkbook.worksheets(xWs).range("C1") = [Forms]![FieldInfo]![Text8].DefaultValue
        objworkbook.worksheets(xWs).range("D1") = [Forms]![FieldInfo]![Text10].DefaultValue
        objworkbook.worksheets(xWs).range("E1") = [Forms]![FieldInfo]![Text12].DefaultValue
        objworkbook.worksheets(xWs).range("F1") = [Forms]![FieldInfo]![Text14].DefaultValue
        objworkbook.worksheets(xWs).range("G1") = [Forms]![FieldInfo]![Text19].DefaultValue
        objworkbook.worksheets(xWs).range("H1") = [Forms]![FieldInfo]![Text21].DefaultValue
        objworkbook.worksheets(xWs).range("I1") = [Forms]![FieldInfo]![Text23].DefaultValue
        objworkbook.worksheets(xWs).range("J1") = [Forms]![FieldInfo]![Text25].DefaultValue
        objworkbook.worksheets(xWs).range("K1") = [Forms]![FieldInfo]![Text27].DefaultValue
        DoCmd.Close acForm, "FieldInfo"
        '========================================================================
        'FIX WORK BOOK CONTENTS
        'This will fix the workbook contents ie. the '00/00/000' , 'none' within this workbook

        i = 1
       
        ColumnName = "Qualification End Date"
        LastRow = objworkbook.worksheets(objworkbook.activesheet.name).UsedRange.Rows.count
           
           
        Do While i <= 3
           
           
            'The x within this do while loop is used to go through each column to find the string within the
            'following column name: Qualification End Date, Qualification Start date, and
            'Qualification Changed Date
            x = 1
            Do While x <= objworkbook.worksheets(objworkbook.activesheet.name).UsedRange.Columns.count
               
                'SColumn = oXL.Application.worksheetfunction.match(ColumnName, objworkbook.worksheet.range(ColumnNumbToLet(x) & "1:" & ColumnNumbToLet(x)"1" & LastRow), 0)
                On Error Resume Next
                'This looks at the current heading (first row) and if it does not matches any of the
                'Column names it will add 1 to x to search for the next column
                If objworkbook.worksheets(objworkbook.activesheet.name).range(ColumnNumbToLet(x) & "1").Value <> ColumnName Then
                    x = x + 1
                'If the column name does match process the following
                Else
           
           
                    SColumn = x  'This is the column number for the found column name
                        '==========================
                        'Excel Find function could not work
                        'With Sheets(ActiveSheet.name).Range("A1:K11")
                        'SColumn = Range("A1:K100").Find(ColumnName, Range("A1"), xlValues, xlWhole, xlByColumns, xlNext).Column
                        'End With
                        '=============================
                       
                        'This will go through all cells within the found column to change any
                        'cells that have the value: '00/00/0000' or 'None'
                        count = 1
                        'This will convert the number column to a letter column
                        Scolumn2 = ColumnNumbToLet(SColumn)
                        Do While count <= LastRow
                            If objworkbook.worksheets(objworkbook.activesheet.name).range(Scolumn2 & count).Value = "00/00/0000" Then
                               objworkbook.worksheets(objworkbook.activesheet.name).range(ColumnNumbToLet(SColumn) & count).Value = ""
                            ElseIf objworkbook.worksheets(objworkbook.activesheet.name).range(Scolumn2 & count).Value = "None" Then
                                objworkbook.worksheets(objworkbook.activesheet.name).range(ColumnNumbToLet(SColumn) & count).Value = ""
                            End If
                            count = count + 1
                        Loop
               
                x = x + 1
                End If
           
            Loop 'End loop for x
           
        'Search for the next column for the belowed strings
        ColumnName = "Qualification Changed Date"
       
        If i = 2 Then ColumnName = "Qualification Start Date"
        i = i + 1
        Loop
        'END of fix for 00/00/00 and 'none'
ASKER CERTIFIED SOLUTION
harfang

Our community of experts have been thoroughly vetted for their expertise and industry experience.

Join our community to see this answer!
Unlock 1 Answer and 5 Comments.
Start Free Trial
Learn from the best

Network and collaborate with thousands of CTOs, CISOs, and IT Pros rooting for you and your success.

Andrew Hancock - VMware vExpert
See if this solution works for you by signing up for a 7 day free trial.
Unlock 1 Answer and 5 Comments.
Try for 7 days

”The time we save is the biggest benefit of E-E to our team. What could take multiple guys 2 hours or more each to find is accessed in around 15 minutes on Experts Exchange.

-Mike Kapnisakis, Warner Bros