Creating table from Excel

[coughnut]

I'm trying to create a table from Excel data that I am importing to Access. The first thing I want to make sure is that I am able to create a table and later populate it. But I am having no luck creating the table. Can any one be of soem help:

Public Sub AddFields()

Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim tdfNew As TableDef

Dim objXL As Excel.Application
Dim objWkb As Excel.Workbook
Dim objSht As Excel.Worksheet

Dim iRow As Integer
Dim strField As String
Dim strFieldType As String

'--- set a reference to Excel
Set objXL = New Excel.Application
'--- open the workbook
'Set objWkb = objXL.Workbooks.Open("C:\temp\Data to 12-31-2004.xls")
Set objWkb = objXL.Workbooks.Open(filenameinput.Value)
'--- set a reference to the correct worksheet
Set objSht = objWkb.Worksheets("Data")

'current database
Set db = CurrentDb

Set tdfNew = db.CreateTableDef("Table")


Set db = Nothing
Set rs = Nothing
Set tdfNew = Nothing

End Sub

 

[PHV]

Why not simply using the DoCmd.TransferSpreadsheet method ?

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[coughnut]

The reason why I am not using the transferSpredsheet method is becasue my table needs to have fields that are located in different columns of the spredsheet.

 

[PHV]

Transfer the worksheet into temporary table(s) and then use a maketable query.

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[coughnut]

Could I get a litle more help? What do oyu mean the maketable query?

 

[PHV]

SELECT field list
INTO newTable
FROM ...

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[coughnut]

Thanks, but I am new to VBA in access and was wonderring if you have any sample code that I could take a look at doing just what you have explained...

 

[perrymans]

You want code? I'll give you code!

Below, I open a spreadsheet, delete empty rows, cycle through looking for a specific piece of information and copy that to column 2 (all info is in column 1 and is broken into many tables in the Append queries), creating a primary key and association (a problem specific to my spreadsheets).

Then I import it using the Transferspreadsheet function, add a primary key to the table. next I check to see if it has been imported before, then begin splitting the information.

In a second DB, I split is further into normalized data.

Sean.

Option Compare Database

Function SearchForString(sFile As String)

   ' Excel object variables
   Dim appExcel As Excel.Application
   Dim wbk As Excel.Workbook
   Dim wks As Excel.Worksheet
   
   ' Access object variables
   Dim LSearchRow As Integer
   Dim LCopyToRow As Integer
   Dim strPOLine As String
   Dim strRowValue As String
   Dim strIdentifyRow As String
   Dim intPOLinePO As Integer
   Dim iResponse As Integer
    
   On Error GoTo Err_Execute

   ' Create the Excel Application, Workbook and Worksheet and Database object
   Set appExcel = GetObject(, "Excel.Application")
   Set wbk = appExcel.Workbooks.Open(sFile)
    
   ' Load current worksheet.  Find used range to determine row count.
   Set wks = appExcel.Worksheets(1)
    
    Call DelRows(sFile, wks, appExcel)
    
    'Start search in row 1
    LSearchRow = 1

    'Start copying data to column 2 in shhet 1 (row counter variable)
    LCopyToRow = 1

    
    While Len(appExcel.Range("A" & CStr(LSearchRow)).Value) > 0

        strRowValue = (appExcel.Range("A" & CStr(LSearchRow)).Value)
        strIdentifyRow = Left(Trim(strRowValue), 10)
        If InStr(1, strIdentifyRow, "45") = 1 Then
            'If value in column A = criteria, copy key value to column 2
            strPOLinePO = Trim(Left(Trim(Mid(strRowValue, (InStr(strRowValue, " ")), (Len(strRowValue)))), 8))
            strPOLine = strPOLinePO
        ElseIf InStr(1, strIdentifyRow, "/") = 3 Then
            strPOLine = strPOLinePO
        Else
            GoTo SkipRow
        End If
            
        appExcel.Range("B" & CStr(LSearchRow)).Select
        ActiveCell.Value = strPOLine

SkipRow:
        LSearchRow = LSearchRow + 1
        LCopyToRow = LCopyToRow + 1
    
    Wend

    appExcel.Application.DisplayAlerts = False
    wbk.Close SaveChanges:=True
    appExcel.Application.DisplayAlerts = True
    
    Set wks = Nothing
    Set wbk = Nothing
    Set appExcel = Nothing

    Call ExcelImport(sFile)
    Call ImportCheck(iResponse, sFile)
    
    Select Case iResponse
        Case 0
            Call SplitImport
        Case 1
            Call SplitImport
        Case 2
            DoCmd.SetWarnings False
            DoCmd.DeleteObject acTable, "Sheet1"
            DoCmd.SetWarnings True
    End Select
    
    Exit Function

Err_Execute:
    Select Case Err.Number
        Case 429
            'Excel is not running; open Excel with CreateObject
            Set appExcel = CreateObject("Excel.Application")
            Resume Next
        Case Else
            MsgBox Err.Number & ": " & Err.Description
            Exit Function
    End Select
End Function

Function DelRows(sFile As String, wks As Excel.Worksheet, appExcel As Excel.Application)

   ' Access object variables
   Dim DMyRow As Range
   Dim DLSearchRow As Integer

DLSearchRow = 1
    For Each DMyRow In ActiveSheet.UsedRange.Rows
        If Len(appExcel.Range("A" & CStr(DLSearchRow)).Value) = 0 Then
            appExcel.Range("A" & CStr(DLSearchRow)).EntireRow.Delete
        End If
        
        DLSearchRow = DLSearchRow + 1
            
    Next DMyRow
    
End Function

Function ExcelImport(sFile As String)
On Error GoTo Err_Execute

'DoCmd.RunSQL "DROP TABLE Sheet1;"

DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
    "Sheet1", sFile, False

    'MsgBox "File imported, ready to split."

    DoCmd.RunSQL "ALTER TABLE Sheet1 ADD COLUMN ID COUNTER(1,1) CONSTRAINT PrimaryKey PRIMARY KEY;"

Exit Function

Err_Execute:
    Select Case Err.Number
    Case 3376
        Resume Next
    Case Else
        MsgBox Err.Number & ": " & Err.Description
        Exit Function
    End Select

End Function


Function SplitImport()
On Error GoTo ErrHandler

Dim db As DAO.Database
Dim rsS As DAO.Recordset
Dim strSQL As String
Dim lngReportID As Long
Dim qdfSQL As QueryDef
Dim sngTime As Single

Set db = CurrentDb()

    Set qdfSQL = db.QueryDefs("AppQ_Imported")
        qdfSQL.Execute

DoCmd.SetWarnings False
    
    Set qdfSQL = db.QueryDefs("AppQ_Report")
        qdfSQL.Execute
   
    strSQL = "SELECT Max(Tbl_Report.ReportID) AS MaxOfReportID FROM Tbl_Report;"
    Set rsS = db.OpenRecordset(strSQL, dbOpenDynaset)
    lngReportID = rsS!MaxOfReportID
        
    strSQL = "INSERT INTO Tbl_PO_Line_Temp ( PONum, CustEmpID, Name, ReportID )" & _
                "SELECT SelQ_PO_Line_1.PONum, SelQ_PO_Line_1.CustEmpID, " & _
                "SelQ_PO_Line_1.Name, " & lngReportID & " FROM SelQ_PO_Line_1;"
    
    DoCmd.RunSQL strSQL
    
    DoCmd.OpenQuery "AppQ_PO_Line_Final"
    DoCmd.OpenQuery "DelQ_PO_Line_Temp"
    DoCmd.OpenQuery "AppQ_PO_SubLine_Temp_1"
    DoCmd.OpenQuery "AppQ_PO_SubLine_Temp_2"
    DoCmd.OpenQuery "AppQ_PO_SubLine_Final"
    DoCmd.OpenQuery "DelQ_PO_SubLine_Temp_1"
    DoCmd.OpenQuery "DelQ_PO_SubLine_Temp_2"
    DoCmd.OpenQuery "AppQ_Imported"
  
    DoCmd.DeleteObject acTable, "Sheet1"
        
    DoCmd.SetWarnings True

Exit Function

ErrHandler:
MsgBox Err.Number & ": " & Err.Description

End Function

Function ImportCheck(iResponse As Integer, sFile As String)
On Error Resume Next

    Dim strSearch As String
    Dim strSQL As String
    Dim rsI As DAO.Recordset
    Dim rsC As DAO.Recordset
    Dim lngLoc As Long
    Dim lngRow As Long
    Dim lngI As Long
    Dim Msg, Style, Title, Help, Ctxt, Response, MyString
        
    iResponse = 0
    Set rsI = CurrentDb.OpenRecordset("SelQ_DateTime")
        
        strSearch = rsI!DateTime
    
    
    Set rsC = CurrentDb.OpenRecordset("Tbl_Imported")
            If Not rsC.BOF Then
                lngRow = 1
                Do Until rsC.EOF
                
                    For lngI = 0 To rsC.Fields.Count - 1
                        
                        lngLoc = InStr(1, rsC.Fields(lngI).Value, strSearch)
                        If lngLoc <> 0 Then
                            Msg = "This report, '" & sFile & "' has already been imported! Do you want to import it again?"    ' Define message.
                            Style = vbYesNo + vbCritical + vbDefaultButton2    ' Define buttons.
                            Title = "Warning! Importing again may cause duplicate records!"    ' Define title.
                            Response = MsgBox(Msg, Style, Title)
                            
                            If Response = vbYes Then    ' User chose Yes.
                                iResponse = 1
                                GoTo GoingAnyway
                            Else    ' User chose No.
                                iResponse = 2
                                GoTo GoingAnyway
                            End If

                        
                        End If
                        lngLoc = 0
                        
                    Next lngI
                    
                    lngRow = lngRow + 1
                    rsC.MoveNext
                Loop
            End If
GoingAnyway:
    rsC.Close
    rsI.Close
    Set rsC = Nothing
    Set rsI = Nothing
    
End Function

 

[perrymans]

As an aside to what the others suggested, use the Trasnferspreadsheet, create a primary key (see my code), then use append or make table queries to begin splitting it out from there.

In Design view of a query, the menu Query has the options to change the query type.

It is much easier to first get it into Access, then split it apart from there.

Sean.