Insert All Records From Worksheet To Access Table

**goss** · 02-14-2012, 12:53 PM

Hi All,

using Excel/Access 2007

In code below, I would like to INSERT all records from worksheet "tmpf" to a table in Access
I copied the header row from the worksheet to a new worksheet
I imported the new worksheet to Access to create a new table to make sure headers are exactly the same
I verified all string variables I am passing from the worksheet
I verified that I selelcted the correct file in the GetOpenFilename method.
I receive no error messages
I checked the temporary workbook and worksheets - all data is as expected
The worksheet I am trying to INSERT from has 10 Fields, 1 Header row, and 467,696 records

When all is complete I check the target table in Access - nothing.
Any ideas what else I can check as to why this process is not working?

thx
w

Option Explicit

Sub AppendTextFile()
    '
    'Purpose:
    '1.) Allow user to select file to be appended to table specified through UI on wks
    '2.) Load data from selected text file into Excel
    '3.) Perform any maintenenace routines on the dataset
    '4.) Load to Access
    '
    'References:
    '========================================
    '1.) Microsoft ActiveX Data Objects 2.7 Library
    '2.) Microsoft Scripting Runtime
    '
    'To set Reference:
    'In VBE, click Tools, References, Scroll for the correct library
    'tick the check box, click OK
    '
    'Date       Developer       Action
    '---------------------------------------------
    '02/10/12   ws              Created
    
    Dim Conn As New ADODB.Connection
    Dim wb As Workbook
    Dim wbTmp As Workbook
    Dim ws As Worksheet
    Dim wsTmp As Worksheet
    Dim wsTmpf As Worksheet
    Dim strTmpPath As String
    Dim strArchivePath As String
    Dim strExportFile As String
    Dim strDBPath As String
    Dim strDB As String
    Dim strDBTable As String
    Dim strDBPathFile As String
    Dim strFilter As String
    Dim strTitle As String
    Dim intFilterIndex As Integer
    Dim varFilename As Variant
    Dim strFilenamePath As String
    Dim strSQL As String

    'Initialize
        With Application
            .ScreenUpdating = False
            .Calculation = xlCalculationManual
            .DisplayAlerts = False
        End With
        
        strTmpPath = ""
        strDBPath = ""
        strDB = ""
        strDBTable = ""
        strArchivePath = ""
        strFilter = "Text Files (*.csv),*.csv,"
        intFilterIndex = 1 '3?
        strTitle = "Append Text File"

        Set wb = ThisWorkbook
        Set ws = wb.Worksheets("AppendText")
        With ws
            strDBPath = .Range("B4")
            strDB = .Range("B5")
            strDBTable = .Range("B6")
            strArchivePath = .Range("B7")
            strTmpPath = .Range("B8")
        End With
        
         If Right$(strArchivePath, 1) <> "\" Then strArchivePath = strArchivePath & _
        "\"
        
    ' Select Start Drive and Path
        ChDrive (Left$(strDBPath, 1))
        ChDir (strArchivePath)
        With Application
            varFilename = .GetOpenFilename(strFilter, intFilterIndex, strTitle)
            strFilenamePath = .ActiveWorkbook.Path
            
            'Reset Start Drive/Path
            ChDrive (Left(.DefaultFilePath, 1))
            ChDir (.DefaultFilePath)
        End With
        
    'Exit on cancel
    If varFilename = False Then
        MsgBox "No file was selected"
        Exit Sub
    End If
    
    'Temporary workspace''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Use for loading text file to Excel'''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim strFileName As String
    Dim lngFileNameLength As Long
    
    lngFileNameLength = Len(varFilename)
    strFileName = CStr(Left(varFilename, lngFileNameLength - 4))
    strFileName = Replace(strFileName, "\", "_")
    strFileName = Replace(strFileName, ":", "")
    
    Set wbTmp = Workbooks.Add
    ChDir (strTmpPath)
        With wbTmp
            .SaveAs Filename:="AppData_" & strFileName & ".xlsx" '<-Original
'            .SaveAs Filename:="AppData_" & strFileName & ".xlsx" '<-Modified 02/13/12
            .Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "tmp"
            .Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "tmpf"
            Set wsTmp = .Worksheets("tmp")
            Set wsTmpf = .Worksheets("tmpf")
        End With
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    'Load data from selected text file into Excel'''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim wbOpen
    Dim sht As Worksheet
    Dim FSO As Object
    Dim i As Long
    Dim sFolder As String
    Dim fldr As Object
    Dim Folder As Object
    Dim file As Object
    Dim Files As Object
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sFolder = strFilenamePath
    If sFolder <> "" Then
        Set wbOpen = Workbooks.Open(Filename:=varFilename)
        With ActiveWorkbook
            For Each sht In ActiveWorkbook.Worksheets
                sht.UsedRange.Copy
                wsTmp.Range("A65536").End(xlUp).PasteSpecial (xlPasteValuesAndNumberFormats)
            Next sht
            wbOpen.Close
        End With
    End If
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'End load data''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Perform any maintenenace routines
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Copy dataset w/wo transformations to blank worksheet

        Dim lngLastColumn As Long
        Dim lngRows As Long
        Dim rngCopy As Range
        With wsTmp
            'Find last column
'            If WorksheetFunction.CountA(Cells) > 0 Then
'                lngLastColumn = .Cells.Find(What:="*", After:=[A1], _
'                                SearchOrder:=xlByColumns, _
'                                SearchDirection:=xlPrevious).Column
'            End If
            lngLastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
        
            'Find last row
            lngRows = wsTmp.Cells(Rows.Count, 1).End(xlUp).Row 'Find last Row
        
            'Range to copy
            .Range("A1").Select
            Set rngCopy = Selection.CurrentRegion
            Set rngCopy = rngCopy.Resize(lngRows, lngLastColumn)
            
            'Copy/Paste
            rngCopy.Copy Destination:=wsTmpf.Range("A1")
        End With
    'End copy
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    'Connection String
    Set Conn = New ADODB.Connection
    Conn.ConnectionString = _
    "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=" & strDBPath & strDB & ";" & _
    "Persist Security Info=False"
    Conn.Open
        
    'Load to Access
    strSQL = "INSERT INTO " & strDBTable & " SELECT * FROM [tmpf$] IN '" _
    & wbTmp.FullName & "' 'Excel 12.0;'"

    'Tidy up
    wbTmp.Save
    wbTmp.Close
    Conn.Close
    Set Conn = Nothing
    Set wb = Nothing
    Set wbTmp = Nothing
    Set ws = Nothing
    Set sht = Nothing
    Set wsTmp = Nothing
    Set wsTmpf = Nothing
    Set FSO = Nothing
    Set fldr = Nothing
    Set Folder = Nothing
    Set file = Nothing
    Set Files = Nothing
    Set rngCopy = Nothing

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
        
End Sub

**goss** · 02-14-2012, 02:09 PM

Genius,

I forgot the ADO Connection execute command after the SQL String

Conn.Execute (strSQL)

Thanks for letting me use the forum as a sounding board
Full revised code below
Works great!

thx
w

Option Explicit

Sub AppendTextFile()
    '
    'Purpose:
    '1.) Allow user to select file to be appended to table specified through UI on wks
    '2.) Load data from selected text file into Excel
    '3.) Perform any maintenenace routines on the dataset
    '4.) Load to Access
    '
    'References:
    '========================================
    '1.) Microsoft ActiveX Data Objects 2.7 Library
    '2.) Microsoft Scripting Runtime
    '
    'To set Reference:
    'In VBE, click Tools, References, Scroll for the correct library
    'tick the check box, click OK
    '
    'Date       Developer       Action
    '---------------------------------------------
    '02/10/12   ws              Created
    
    Dim Conn As New ADODB.Connection
    Dim wb As Workbook
    Dim wbTmp As Workbook
    Dim ws As Worksheet
    Dim wsTmp As Worksheet
    Dim wsTmpf As Worksheet
    Dim strTmpPath As String
    Dim strArchivePath As String
    Dim strExportFile As String
    Dim strDBPath As String
    Dim strDB As String
    Dim strDBTable As String
    Dim strDBPathFile As String
    Dim strFilter As String
    Dim strTitle As String
    Dim intFilterIndex As Integer
    Dim varFilename As Variant
    Dim strFilenamePath As String
    Dim strSQL As String

    'Initialize
        With Application
            .ScreenUpdating = False
            .Calculation = xlCalculationManual
            .DisplayAlerts = False
        End With
        
        strTmpPath = ""
        strDBPath = ""
        strDB = ""
        strDBTable = ""
        strArchivePath = ""
        strFilter = "Text Files (*.csv),*.csv,"
        intFilterIndex = 1 '3?
        strTitle = "Append Text File"

        Set wb = ThisWorkbook
        Set ws = wb.Worksheets("AppendText")
        With ws
            strDBPath = .Range("B4")
            strDB = .Range("B5")
            strDBTable = .Range("B6")
            strArchivePath = .Range("B7")
            strTmpPath = .Range("B8")
        End With
        
         If Right$(strArchivePath, 1) <> "\" Then strArchivePath = strArchivePath & _
        "\"
        
    ' Select Start Drive and Path
        ChDrive (Left$(strDBPath, 1))
        ChDir (strArchivePath)
        With Application
            varFilename = .GetOpenFilename(strFilter, intFilterIndex, strTitle)
            strFilenamePath = .ActiveWorkbook.Path
            
            'Reset Start Drive/Path
            ChDrive (Left(.DefaultFilePath, 1))
            ChDir (.DefaultFilePath)
        End With
        
    'Exit on cancel
    If varFilename = False Then
        MsgBox "No file was selected"
        Exit Sub
    End If
    
    'Temporary workspace''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Use for loading text file to Excel'''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim strFileName As String
    Dim lngFileNameLength As Long
    
    lngFileNameLength = Len(varFilename)
    strFileName = CStr(Left(varFilename, lngFileNameLength - 4))
    strFileName = Replace(strFileName, "\", "_")
    strFileName = Replace(strFileName, ":", "")
    
    Set wbTmp = Workbooks.Add
    ChDir (strTmpPath)
        With wbTmp
            .SaveAs Filename:="AppData_" & strFileName & ".xlsx" '<-Original
'            .SaveAs Filename:="AppData_" & strFileName & ".xlsx" '<-Modified 02/13/12
            .Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "tmp"
            .Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "tmpf"
            Set wsTmp = .Worksheets("tmp")
            Set wsTmpf = .Worksheets("tmpf")
        End With
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    'Load data from selected text file into Excel'''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim wbOpen
    Dim sht As Worksheet
    Dim FSO As Object
    Dim i As Long
    Dim sFolder As String
    Dim fldr As Object
    Dim Folder As Object
    Dim file As Object
    Dim Files As Object
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sFolder = strFilenamePath
    If sFolder <> "" Then
        Set wbOpen = Workbooks.Open(Filename:=varFilename)
        With ActiveWorkbook
            For Each sht In ActiveWorkbook.Worksheets
                sht.UsedRange.Copy
                wsTmp.Range("A65536").End(xlUp).PasteSpecial (xlPasteValuesAndNumberFormats)
            Next sht
            wbOpen.Close
        End With
    End If
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'End load data''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Perform any maintenenace routines
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Copy dataset w/wo transformations to blank worksheet

        Dim lngLastColumn As Long
        Dim lngRows As Long
        Dim rngCopy As Range
        With wsTmp
            'Find last column
'            If WorksheetFunction.CountA(Cells) > 0 Then
'                lngLastColumn = .Cells.Find(What:="*", After:=[A1], _
'                                SearchOrder:=xlByColumns, _
'                                SearchDirection:=xlPrevious).Column
'            End If
            lngLastColumn = Cells(1, Columns.Count).End(xlToLeft).Column
        
            'Find last row
            lngRows = wsTmp.Cells(Rows.Count, 1).End(xlUp).Row 'Find last Row
        
            'Range to copy
            .Range("A1").Select
            Set rngCopy = Selection.CurrentRegion
            Set rngCopy = rngCopy.Resize(lngRows, lngLastColumn)
            
            'Copy/Paste
            rngCopy.Copy Destination:=wsTmpf.Range("A1")
        End With
    'End copy
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    'Connection String
    Set Conn = New ADODB.Connection
    Conn.ConnectionString = _
    "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=" & strDBPath & strDB & ";" & _
    "Persist Security Info=False"
    Conn.Open
        
    'Load to Access
    strSQL = "INSERT INTO " & strDBTable & " SELECT * FROM [tmpf$] IN '" _
    & wbTmp.FullName & "' 'Excel 12.0;'"
    
    Conn.Execute (strSQL)
    
    'Tidy up
    wbTmp.Save
    wbTmp.Close
    Conn.Close
    Set Conn = Nothing
    Set wb = Nothing
    Set wbTmp = Nothing
    Set ws = Nothing
    Set sht = Nothing
    Set wsTmp = Nothing
    Set wsTmpf = Nothing
    Set FSO = Nothing
    Set fldr = Nothing
    Set Folder = Nothing
    Set file = Nothing
    Set Files = Nothing
    Set rngCopy = Nothing

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
        
End Sub

Insert All Records From Worksheet To Access Table

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Insert All Records From Worksheet To Access Table

Re: Insert All Records From Worksheet To Access Table

Thread Information

Users Browsing this Thread

Bookmarks

Bookmarks

Posting Permissions